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

编辑

好的，先生，试一试。确保在顶部指定文件夹和搜索文本。提取电子邮件后，将弹出一个消息框。

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