asked on

How to parse Outlook Subject and Write to Excel

I have a couple of VBA macros that if married properly, could do what I'm trying to accomplish. I just don't know how to marry them. The objective is to parse the subject line of messages in a particular folder and export only the computer name into the Excel spreadsheet. The subject line is in the following format:

From Server1 This file has been found on COMPUTERXYZ

I need COMPUTERXYZ from each email written to the spreadsheet. I've attached the 2 VBA scripts.
VBA1.txt
VBA2.txt

ltlbearand3

I am not completely sure I understand what you want. Do you just want emails with a computer name to export or do you just want the computer name and not the full subject line? I made a change to the script to put the computer name in the last column in the spreadsheet. Hopefully this will help you get what you need:

"From XXXX This file has been found on XXXXX"

Try this code:

ub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intRow As Integer, _
        intVersion As Integer, _
        strFilename As String
    strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    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) = "Received"
            .Cells(1, 3) = "Sender"
	    .Cells(1, 4) = "ComputerName"	' *** Added for EE Q#28554614 *****
        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, 2) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
		excWks.Cells(intRow, 4) = Right(olkMsg.Subject, Len(olkMsg.Subject) - (InStr(1, olkMsg.Subject, "found on") + 8)) 	' *** Added for EE Q#28554614 *****
                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

Open in new window

SnAkEhIpS

ASKER

I'm getting the following error when I try to run it...

SnAkEhIpS

ASKER

I'll try to clarify what I'm seeking. I receive several emails with the same subject line. The only difference between them is the computer name in reference.

Email #1 Subject Line: "Server Apple has reported a virus on CMP-1567"
Email #2 Subject Line: "Server Apple has reported a virus on CMP-2954"
Email #3 Subject Line: "Server Apple has reported a virus on CMP-5585"
etc..

I'd like a spreadsheet or a tab delimited text file that lists all of the computers. For example:

CMP-1567
CMP-2954
CMP-5585

ltlbearand3

There is nothing I added that should have caused that error. You may need to step through the code. Your code prompts for a path and file at the beginning. Did you verify that you entered and path and a file name? I have a couple other things you can try and will post those in a minute.

ltlbearand3

Ok. I took a look at the code in more detail. I added some error handling to the main sub to help in troubleshooting. I also changed from using an input box to select your file to using the Excel objects Get File name. This should help in stopping problems from that piece of code. Try this:

Sub ExportMessagesToExcel()
        On Error GoTo ExportMessagesToExcel_Err:
    
        Dim olkMsg As Object
        Dim excApp As Object
        Dim excWkb As Object
        Dim excWks As Object
        Dim intRow As Integer
        Dim intVersion As Integer
        Dim strFilename As String
        
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        
10      strFilename = excApp.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xls, ), *.xls", Title:="Save File As")
        
20      If LenB(strFilename) > 0 Then
30          intVersion = GetOutlookVersion()
            
            'Write Excel Column Headers
40          With excWks
50              .Cells(1, 1) = "Subject"
60              .Cells(1, 2) = "Received"
70              .Cells(1, 3) = "Sender"
80              .Cells(1, 4) = "ComputerName"   ' *** Added for EE Q#28554614 *****
90          End With
100         intRow = 2
            
            'Write messages to spreadsheet
110         For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
120             If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
130                 excWks.Cells(intRow, 1) = olkMsg.Subject
140                 excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
150                 excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
160                 excWks.Cells(intRow, 4) = Right(olkMsg.Subject, Len(olkMsg.Subject) - (InStr(1, olkMsg.Subject, " virus on") + 8))   ' *** Added for EE Q#28554614 *****
170                 intRow = intRow + 1
                End If
            Next
            
180         excWkb.SaveAs strFilename
190         excWkb.Close
        End If
    
        MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
    
Release:
        Set olkMsg = Nothing
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
Exit Sub
        
ExportMessagesToExcel_Err:
        MsgBox "Error Number: " & Err.Number & vbCrLf & "On Line " & Erl & vbCrLf & Err.Description, vbCritical, "VBA Code Error"
        
        Resume Release
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

Open in new window

SnAkEhIpS

ASKER

Got a VBA error on line 10 (strFilename = excApp.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xls, ), *.xls", Title:="Save File As")

ltlbearand3

What version of Outlook is installed and what version of Excel is installed?

I ran this code on my machine and it went fine. We may have different versions and we may have to adjust the code for that.

SnAkEhIpS

ASKER

Perhaps that's the case. I am running Office365ProPlus. However, the Excel and Outlook clients are both installed on my computer and I am running Outlook in cached mode. I'm not using the browser-based OWA for accessing my email, I am using the client.

ltlbearand3

I am not familiar with writing code for Office365ProPlus, but lets try a couple things to figure this out. In the VBA code section in Outlook, Is there a menu for Tools >> References? If so, scroll down and see if there is an item listed for "Microsoft Excel xx.x Object Library" where xx.x will be a number like 15.1. Let me know what you see.

SnAkEhIpS

ASKER

Microsoft Excel 15.0 Object Library is available but not selected. I selected it and ran the macro again. This time I got an error similar to the previous one, but the line number changed. Here is what I got:

SnAkEhIpS

ASKER

Could this have any bearing? http://msdn.microsoft.com/en-us/library/office/ff864733(v=office.15).aspx

ltlbearand3

I am not sure if that makes a difference or not. Not having worked with that product, I am not sure how it affects the code. I will keep looking for options. I also recommend that you click on the link to request attention. This will help generate an email out to some more experts to take a look. Maybe someone else in EE can provide some better instruction. In that request, I suggest you ask a moderator to add Office365 to the tags.

ltlbearand3

Since you have the reference available, also try moving to early binding. Go ahead and leave that reference checked and then use this code. Make sure to save the code before running. Also, I recommend using Debug >> Compile Project before trying to run and see if you get any errors. If not, then try to run the code.

Sub ExportMessagesToExcel()
        On Error GoTo ExportMessagesToExcel_Err:
    
        Dim olkMsg As Object
        Dim excApp As Excel.Application
        Dim excWkb As Excel.Workbook
        Dim excWks As Excel.Worksheet
        Dim intRow As Integer
        Dim intVersion As Integer
        Dim strFilename As String
        
2       Set excApp = New Excel.Application
4       Set excWkb = excApp.Workbooks.Add()
6       Set excWks = excWkb.ActiveSheet
        
10      strFilename = excApp.GetSaveAsFilename(fileFilter:="Excel Workbook (*.xls, ), *.xls", Title:="Save File As")
        
20      If LenB(strFilename) > 0 Then
30          intVersion = GetOutlookVersion()
            
            'Write Excel Column Headers
40          With excWks
50              .Cells(1, 1) = "Subject"
60              .Cells(1, 2) = "Received"
70              .Cells(1, 3) = "Sender"
80              .Cells(1, 4) = "ComputerName"   ' *** Added for EE Q#28554614 *****
90          End With
100         intRow = 2
            
            'Write messages to spreadsheet
110         For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
                'Only export messages, not receipts or appointment requests, etc.
120             If olkMsg.Class = olMail Then
                    'Add a row for each field in the message you want to export
130                 excWks.Cells(intRow, 1) = olkMsg.Subject
140                 excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
150                 excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
160                 excWks.Cells(intRow, 4) = Right(olkMsg.Subject, Len(olkMsg.Subject) - (InStr(1, olkMsg.Subject, " virus on") + 8))   ' *** Added for EE Q#28554614 *****
170                 intRow = intRow + 1
                End If
            Next
            
180         excWkb.SaveAs strFilename
190         excWkb.Close
        End If
    
        MsgBox "Process complete.  A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
    
Release:
        Set olkMsg = Nothing
        Set excWks = Nothing
        Set excWkb = Nothing
        Set excApp = Nothing
Exit Sub
        
ExportMessagesToExcel_Err:
        MsgBox "Error Number: " & Err.Number & vbCrLf & "On Line " & Erl & vbCrLf & Err.Description, vbCritical, "VBA Code Error"
        
        Resume Release
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

Open in new window

David Lee

Hi, jcb431.

Since I'm the author of the code you posted, maybe I can be of some help here. Do you want just the computer name from the subject line, or do you want the other details too (e.g. subject, sender's email address, time received, etc.)?

Qlemo

ltlbearand3, are you seriously still using BASIC line numbers? That got obsolete in the 90s already ...

SnAkEhIpS

ASKER

BlueDevilFan...I'm really only interested in extracting the computer names, if that makes it any easier.

David Lee

It makes a lot of the code that's there unnecessary, which makes this all a bit easier. I'll make the changes and post the code as soon as I can (hopefully by the end of the day).

ASKER CERTIFIED SOLUTION

David Lee

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

SnAkEhIpS

ASKER

Thank you. It is working. I've discovered that I have a separate, but perhaps related issue. When I attempt to open the output file I receive the error below. However, when I open Excel first, then select File > Open > OutputFile.xlsx, it opens successfully. I can research that one. Thank you again for your help!!!

David Lee

You're welcome.

I've not seen that error message before. Do other workbooks open okay?