Solved

How to parse Outlook Subject and Write to Excel

Posted on 2014-11-10
21
679 Views
1 Endorsement
Last Modified: 2014-11-20
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
1
Comment
Question by:jcb431
  • 8
  • 7
  • 4
  • +1
21 Comments
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40434300
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

0
 

Author Comment

by:jcb431
ID: 40441185
I'm getting the following error when I try to run it...

Run time error
0
 

Author Comment

by:jcb431
ID: 40441203
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
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40441298
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.
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40441417
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

0
 

Author Comment

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

VBA Error line 10
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40443382
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.
0
 

Author Comment

by:jcb431
ID: 40447374
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.
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40448856
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.
0
 

Author Comment

by:jcb431
ID: 40452369
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:

vba-error-Excel-library-enabled.png
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:jcb431
ID: 40453574
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40453903
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.
0
 
LVL 20

Expert Comment

by:ltlbearand3
ID: 40453914
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

0
 
LVL 76

Expert Comment

by:David Lee
ID: 40455395
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.)?
0
 
LVL 68

Expert Comment

by:Qlemo
ID: 40455415
ltlbearand3, are you seriously still using BASIC line numbers? That got obsolete in the 90s already ...
0
 

Author Comment

by:jcb431
ID: 40455754
BlueDevilFan...I'm really only interested in extracting the computer names, if that makes it any easier.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40455828
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).
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 40455970
This should do it assuming that the subject line is consistent.  By consistent I mean that the computer name is aways the last word in the subject and is preceded by a space.

Sub ExportMessagesToExcel()
    Dim olkMsg As Object, _
        excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        lngRow As Long, _
        lngCnt As Long, _
        intPos As Integer, _
        strFil As String
    strFil = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
    If strFil <> "" Then
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Computer"
        End With
        lngRow = 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
                intPos = InStrRev(olkMsg.Subject, " ")
                excWks.Cells(lngRow, 1) = Mid(olkMsg.Subject, intPos + 1)
                lngRow = lngRow + 1
                lngCnt = lngCnt + 1
            End If
        Next
        Set olkMsg = Nothing
        excWkb.SaveAs strFil
        excWkb.Close
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    MsgBox "Process complete.  A total of " & lngCnt & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Open in new window

0
 

Author Comment

by:jcb431
ID: 40456112
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!!!
Excel Open Error
0
 
LVL 76

Expert Comment

by:David Lee
ID: 40456194
You're welcome.

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

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Not sure what the best email signature size is? Are you worried about email signature image size? Follow this best practice guide.
If you don't know how to downgrade, my instructions below should be helpful.
To add imagery to an HTML email signature, you have two options available to you. You can either add a logo/image by embedding it directly into the signature or hosting it externally and linking to it. The vast majority of email clients display l…
Migrating to Microsoft Office 365 is becoming increasingly popular for organizations both large and small. If you have made the leap to Microsoft’s cloud platform, you know that you will need to create a corporate email signature for your Office 365…

747 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now