VBA for Outlook无法正确解析电子邮件

Question

我正在为Outlook编写VBA，它将通过我特定文件夹中的电子邮件，并通过电子邮件正文并解析特定行，然后将其保存到Excel文件中。 到目前为止，我还没有收到任何错误，当我运行它时，它保存了一个Excel文件，但是它只打印出我在程序中回显的“电子邮件”字符串，因此未进行解析。

所以我在从Outlook文件夹中的电子邮件解析正确的信息时遇到了一些问题。 实际上，我不确定它是否甚至可以解析任何内容。

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

这是我解析行的功能：

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

这是我尝试解析的电子邮件的示例； 我把它放在代码格式，以便于阅读。

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  

谢谢高级！！

Answer 1

编辑

好吧，先生，给我一个机会。 确保在顶部指定文件夹和searchtext。 提取电子邮件后，将弹出一个消息框。

Sub ParseContents()

    Dim strTargetFolder : strTargetFolder = "Inbox"
    Dim SearchText: SearchText = "Email: "    

    Dim NS As outlook.NameSpace
    Dim oFld As outlook.Folder
    Set NS = Application.GetNamespace("MAPI")
    For ifld = 1 To NS.Folders.Count
        For ictr = 1 To NS.Folders.Item(ifld).Folders.Count
            ' handle case sensitivity as I can't type worth a crap
            If LCase(NS.Folders.Item(ifld).Folders(ictr).Name) = LCase(strTargetFolder) Then
                'found our target :)
                Set oFld = NS.Folders.Item(ifld).Folders(ictr)
                Exit For  ' found it so lets move on
            End If
        Next
    Next
    'set up a header for the data dump, this is for CSV
    strEmailContents = "Email" & vbCrLf

    Dim EscapeLoops: EscapeLoops = False
    '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 oFld Is Nothing Then
        For Each outlookMessage In oFld.Items
            If TypeOf outlookMessage Is MailItem Then
                If InStr(outlookMessage.Body, SearchText) 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
                    Dim splitter, parsemail: splitter = Split(strMsgBody, vbCrLf)
                    For Each splt In splitter
                        If InStr(splt, SearchText) Then
                            parsemail = splt
                            EscapeLoops = True
                            Exit For
                        End If
                    Next
                    strEmailContents = strEmailContents & "Date/Time: " & outlookMessage.CreationTime & vbCrLf
                    strEmailContents = strEmailContents & ParseTextLinePair(parsemail, SearchText)
                    MsgBox strEmailContents
                    If EscapeLoops Then Exit For
                End If
            End If
        Next
    End If
End Sub
Function ParseTextLinePair(strSource, strLabel)
    Dim Rturn
    If InStr(strSource, vbCrLf) Then
        Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel), InStr(strSource, vbCrLf) - InStr(strSource, strLabel) + Len(strLabel)):
    Else
        Rturn = Mid(strSource, InStr(strSource, strLabel) + Len(strLabel))
    End If
ParseTextLinePair = Trim(Rturn)
End Function