Reverse Engineer Outlook Macro since New Outlook does not allow Macros

[kgylock]

I have a macro I run on Outlook to export email info to Excel from a selected folder in a Second Outlook email box.

I pull the Subject, Received, To, and specific text from the body.

Currently I go into the Outlook folder in the Second Email Box, and run the below Macro:

Const MACRO_NAME = "Export Messages to Excel (Rev 15)"



Sub ExportMessagesToExcel()

Dim olkMsg As Object, _

excApp As Object, _

excWkb As Object, _

excWks As Object, _

intRow As Integer, _

intVersion As Integer, _

strFilename As String, _

strTemp As String, _

arrLines As Variant, _

varLine As Variant

strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)

If strFilename <> "" Then

intVersion = GetOutlookVersion()

Set excApp = CreateObject("Excel.Application")

Set excWkb = excApp.Workbooks.Add()

Set excWks = excWkb.ActiveSheet

'Write Excel Column Headers

With excWks

.Cells(1, 1) = "Subject"

.Cells(1, 2) = "Job Run ID"

.Cells(1, 3) = "Received"

.Cells(1, 4) = "Placeholder"

.Cells(1, 5) = "Owner"

End With

intRow = 2

'Write messages to spreadsheet

For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items

'Only export messages, not receipts or appointment requests, etc.

If olkMsg.Class = olMail Then

'Add a row for each field in the message you want to export

excWks.Cells(intRow, 1) = olkMsg.Subject

excWks.Cells(intRow, 3) = olkMsg.ReceivedTime

excWks.Cells(intRow, 5) = olkMsg.To

arrLines = Split(olkMsg.Body, vbCrLf)

For Each varLine In arrLines

strTemp = Trim(varLine)

If Left(strTemp, 12) = "Job Run id: " Then

excWks.Cells(intRow, 2) = Trim(strTemp)

End If

Next

intRow = intRow + 1

End If

Next

Set olkMsg = Nothing

excWkb.SaveAs strFilename

excWkb.Close

End If

Set excWks = Nothing

Set excWkb = Nothing

Set excApp = Nothing

MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"

End Sub



Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String

Dim olkSnd As Outlook.AddressEntry, olkEnt As Object

On Error Resume Next

Select Case intOutlookVersion

Case Is < 14

If Item.SenderEmailType = "EX" Then

GetSMTPAddress = SMTP2007(Item)

Else

GetSMTPAddress = Item.SenderEmailAddress

End If

Case Else

Set olkSnd = Item.Sender

If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then

Set olkEnt = olkSnd.GetExchangeUser

GetSMTPAddress = olkEnt.PrimarySmtpAddress

Else

GetSMTPAddress = Item.SenderEmailAddress

End If

End Select

On Error GoTo 0

Set olkPrp = Nothing

Set olkSnd = Nothing

Set olkEnt = Nothing

End Function



Function GetOutlookVersion() As Integer

Dim arrVer As Variant

arrVer = Split(Outlook.Version, ".")

GetOutlookVersion = arrVer(0)

End Function



Function SMTP2007(olkMsg As Outlook.MailItem) As String

Dim olkPA As Outlook.PropertyAccessor

On Error Resume Next

Set olkPA = olkMsg.PropertyAccessor

SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")

On Error GoTo 0

Set olkPA = Nothing

End Function







I have no expertise in building Macros and am not sure even where to start to reverse engineer this from an outlook macro to an excel macro

 

[John_w]

Try this Excel VBA macro - put the code in a standard module in an Excel workbook and save it as a macro-enabled workbook (.xlsm extension).

Option Explicit

Const MACRO_NAME = "Import Messages to Excel (Rev 1)"
Const olMail = 43

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If


Public Sub ImportMessagesToExcel()

    Dim OutApp As Object 'Outlook.Application
    Dim OutMAPI As Object 'Outlook.MAPIFolder
    Dim olkMsg As Object, _
    excWkb As Workbook, _
    excWks As Worksheet, _
    intRow As Long, _
    strFilename As String, _
    strTemp As String, _
    arrLines As Variant, _
    varLine As Variant
    
    strFilename = InputBox("Enter a filename (including path) to save the imported messages to.", MACRO_NAME)
    
    If strFilename <> "" Then
    
        Set OutApp = GetOutlookApp
   
        Set excWkb = Application.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Subject"
            .Cells(1, 2) = "Job Run ID"
            .Cells(1, 3) = "Received"
            .Cells(1, 4) = "Placeholder"
            .Cells(1, 5) = "Owner"
        End With
        intRow = 2
        
        'Write messages to spreadsheet
        
        For Each olkMsg In OutApp.ActiveExplorer.CurrentFolder.Items
        
            'Only export messages, not receipts or appointment requests, etc.
            
            If olkMsg.Class = olMail Then
            
                'Add a row for each field in the message you want to export
                
                excWks.Cells(intRow, 1) = olkMsg.Subject
                excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 5) = olkMsg.To
                arrLines = Split(olkMsg.Body, vbCrLf)
                
                For Each varLine In arrLines
                    strTemp = Trim(varLine)
                    If Left(strTemp, 12) = "Job Run id: " Then
                        excWks.Cells(intRow, 2) = Trim(strTemp)
                    End If
                Next
                
                intRow = intRow + 1
            
            End If
        
        Next
        
        Set olkMsg = Nothing
        excWkb.SaveAs strFilename
        excWkb.Close
    
    End If
    
    Set excWks = Nothing
    Set excWkb = Nothing
    Set OutApp = Nothing
    
    MsgBox "Process complete. A total of " & intRow - 2 & " messages were imported.", vbInformation + vbOKOnly, "Import messages to Excel"

End Sub


Private Function GetOutlookApp() As Object 'Outlook.Application
    'Return the Outlook application object
    Set GetOutlookApp = Nothing
    On Error Resume Next
    Set GetOutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If GetOutlookApp Is Nothing Then
        'Outlook isn't running, so start it
        Shell "outlook.exe", vbNormalFocus
        Do
            Sleep 200
            DoEvents
            On Error Resume Next
            Set GetOutlookApp = GetObject(, "Outlook.Application")
            On Error GoTo 0
        Loop While GetOutlookApp Is Nothing
    End If
End Function

PS - when posting VBA code, please put it between VBA code tags, like this:

[CODE=vba]
Code here
[/CODE]