Outlook的VBA未正确分析电子邮件

我正在为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  

提前谢谢你

编辑

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

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

---

这并没有解决我的问题，所以我猜这一定与我最重要的代码有关，因为你从来没有清楚地说明你的问题。你说它解析错误。我需要更多的信息，一个你的解析的例子，以及你想从解析中得到什么。否则它只是，“Yuuuup，dems一些拆分的文本”我试图解析电子邮件正文中的一行…所以在正文中有一点，它说“电子邮件：blah@aol.com我试图解析“email:”后面的电子邮件地址，其代码在第一个代码块中。它没有正确解析，因为当我打开excel文件时，只有“电子邮件”在那里，这是因为我手动打印输出OK，这更有意义。因此，在原始代码中，您可以在

“Email:（许多空格）

上解析它。而不是在

电子邮件：

段后添加空格。只需去掉空格，如果空格太多或太少，则

Instr（）

语句会把它弄乱。另外，您可以在最后对结果进行

trim

。删除空格，然后再试一次。是的，我本来就是这样做的，但它不起作用，在电子邮件正文中，出于某种原因，“email:”和“email:”之间有几个空格blah@aol.com“这就是为什么我把空格放在中间；但我去掉了空格，再试了一次，还是没有成功。