none
VBA for Outlook not parsing email correctly RRS feed

  • Question

  • I am writing a VBA for outlook that will go through emails in my specific folder and go through the email's body and parse a specific line and then save it to an excel file. So far I am not getting any errors and when I run it, it saves an Excel file, but its only prints out an "email" string that I echo within the program, it's not parsed.

    So I am having a bit of a problem parsing the proper information from the emails in the outlook folder. In matter of fact, I'm not sure if it's even parsing anything at all.

    For iCtr = 1 To OutlookNameSpace.Folders.Item(1).Folders.Count
        ' handle case sensitivity as I can't type worth a crap
         If LCase(OutlookNameSpace.Folders.Item(1).Folders(iCtr).Name) = LCase(strTargetFolder) Then
         'found our target :)
            Set outlookFolder = OutlookNameSpace.Folders.Item(1).Folders(iCtr)
         Exit For  ' found it so lets move on
        End If
     Next
     'set up a header for the data dump, this is for CSV
     strEmailContents = "Email" & vbCrLf
    
     'likely should have some error handling here, in case we have found no target folder
     'Set myFolderItem = outlookFolder.Items
     ' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
     If Not outlookFolder Is Nothing Then
         For Each outlookMessage In outlookFolder.Items
            If TypeOf outlookMessage Is MailItem Then
              strMsgBody = outlookMessage.Body  ' assign message body to a Var
              ' then use Sue Moshers code to look for stuff in the body
              ' all of the following stuff in the quotes "" is specific to your needs
    
              strEmailContents = strEmailContents & ParseTextLinePair(strMsgBody, "E-mail:               ")
              strEmailContents = strEmailContents & "," & ParseTextLinePair(strMsgBody, "")
              'add the email message time stamp, just cause i want it
    
              'debug message comment it out for production
               'WScript.echo strEmailContents
               End If
         Next
     End If

    Here is my function to parse the lines:

    Function ParseTextLinePair(strSource, strLabel)
        ' Sue Moshers code
        'commented out type declaration for VBS usgage take out fer VB usage
        Dim intLocLabel 'As Integer
        Dim intLocCRLF 'As Integer
        Dim intLenLabel 'As Integer
        Dim strText 'As String
    
        ' locate the label in the source text
        intLocLabel = InStr(strSource, strLabel)
        intLenLabel = Len(strLabel)
            If intLocLabel > 0 Then
            intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
            If intLocCRLF > 0 Then
                intLocLabel = intLocLabel + intLenLabel
                strText = Mid(strSource, _
                                intLocLabel, _
                                intLocCRLF - intLocLabel)
            Else
                intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
            End If
        End If
        ParseTextLinePair = Trim(strText)   ' this i like
    End Function

    Here is an example of an email I am trying to parse; i have put it in code format so it is easier to read.

    Vendor: 22*********** 
    
    
      Your company may be interested in the following advertisement(s).  
      To learn more about the advertisements below, please visit the  
      ******** Vendor Bid System (VBS) at  
      http://www.****************.com. For specific  
      questions about the solicitation, each advertisement includes  
      contact information for the agency representative who issued it.  
      to view additional information on the advertisement(s) listed  
      below.  
    
      ____________________________________________________________  
      Agency:     ***************************************  
      Agency Ads: http://www.*************.com  
    
      Advertisement Number: ******BLACKEDOUT INFO***********  
      Advertisement Type:   Informational Notice  
      Title:                Centralized Customer Service System (CCSS) - Notice of Public Meeting  
      Advertisement Status: New  
      Agency Contact:       Sheree ***** 
      E-mail:               blah@aol.com  
      Telephone:            (000)-000-0000  

    Thank you in advanced!!


    Thursday, March 20, 2014 8:35 PM

All replies

  • Try

    Sub Test()
    Dim outlookFolder As Outlook.MAPIFolder
    Dim OutlookNameSpace As Outlook.NameSpace
    Dim outlookMessage As Outlook.MailItem
    Const strTargetFolder As String = "Test"
    Dim iCtr As Integer
    Dim strContents As String
    Dim strMsgBody As String
    Dim strEmail As String
    Dim strEmailContents As String
        Set OutlookNameSpace = GetNamespace("MAPI")
        For iCtr = 1 To OutlookNameSpace.GetDefaultFolder(olFolderInbox).folders.Count
            ' handle case sensitivity as I can't type worth a crap
            If LCase(OutlookNameSpace.GetDefaultFolder(olFolderInbox).folders(iCtr).Name) = LCase(strTargetFolder) Then
                'found our target :)
                Set outlookFolder = OutlookNameSpace.GetDefaultFolder(olFolderInbox).folders(iCtr)
                Exit For        ' found it so lets move on
            End If
        Next
        'set up a header for the data dump, this is for CSV
        strEmailContents = "Email" & vbCrLf

        'likely should have some error handling here, in case we have found no target folder
        'Set myFolderItem = outlookFolder.Items
        ' I have commenteted out some items to illustrate the call to Sue'strEmailContents Function
        If Not outlookFolder Is Nothing Then
            For Each outlookMessage In outlookFolder.Items
                strMsgBody = outlookMessage.Body        ' assign message body to a Var
                ' then use Sue Moshers code to look for stuff in the body
                ' all of the following stuff in the quotes "" is specific to your needs
                strEmail = ParseTextLinePair(strMsgBody, "E-mail:               ")
                If Not strEmail = vbNullString Then
                    strEmailContents = strEmailContents & strEmail
                'add the email message time stamp, just cause i want it
                     strEmailContents = strEmailContents & vbCr & outlookMessage.SentOn
                End If
               
                'debug message comment it out for production
                'WScript.echo strEmailContents
            Next
        End If
        MsgBox strEmailContents
    End Sub

    instead


    Graham Mayor - Word MVP
    www.gmayor.com

    Friday, March 21, 2014 12:12 PM