从电子邮件正文中提取字符串

Question

我想从电子邮件正文中提取信息。

电子邮件格式不一致。在某些情况下，代码返回ZERO值。

这是代码的当前迭代。

Sub CopyToExcel()
     Dim xlApp As Object
     Dim xlWB As Object
     Dim xlSheet As Object
     Dim olItem As Outlook.MailItem
     Dim vText As Variant
     Dim sText As String
     Dim vItem As Variant
     Dim oText As Variant
     Dim oItem As String

     Dim i As Long
     Dim rCount As Long
     Dim bXStarted As Boolean
     enviro = CStr(Environ("USERPROFILE"))
     'the path of the workbook
     strPath = enviro & "\Documents\TEST.xlsx"

     If Application.ActiveExplorer.Selection.Count = 0 Then
        MsgBox "No Items selected!", vbCritical, "Error"
        Exit Sub
       End If
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
     If Err <> 0 Then
       Application.StatusBar = "Please wait while Excel source is opened ... "
     Set xlApp = CreateObject("Excel.Application")
     bXStarted = True
       End If
     On Error GoTo 0
    'Open the workbook to input the data
     Set xlWB = xlApp.Workbooks.Open(strPath)
     Set xlSheet = xlWB.Sheets("Sheet1")

     'Process each selected record
       rCount = xlSheet.UsedRange.Rows.Count + 1
        For Each olItem In Application.ActiveExplorer.Selection
        oText = Split(olItem.Subject, ":")
        sText = olItem.Body
        vText = Split(sText, Chr(13))
       'Find the next empty line of the worksheet

          oItem = Trim(oText(1))
          If Len(oText(1)) = 0 Then oText(1) = ""
          'Check each line of text in the message body
          For i = UBound(vText) To 0 Step -1



         If InStr(1, vText(i), "-") > 0 Then
                     vItem = Split(vText(i), Chr(45))
                     xlSheet.Range("A" & rCount) = oText(1)
                     xlSheet.Range("B" & rCount) = Trim(vItem(0))
                     xlSheet.Range("C" & rCount) = Trim(vItem(1))

            End If
          Next i
       xlWB.Save
         rCount = rCount + 1
       Next olItem
       xlWB.Close SaveChanges:=True
       If bXStarted Then
          xlApp.Quit
      End If
      Set xlApp = Nothing
      Set xlWB = Nothing
      Set xlSheet = Nothing
      Set olItem = Nothing

End Sub

该代码适用于此电子邮件。

  

“亲爱的先生/女士，我们希望确认 107.34 STG将提交到您指定的银行账户。这是您的索赔的全部和最终结算。    107.34 - 000001017660912
   John Smith代表公司。“

找到已支付的金额和发票编号，并将其添加到Excel电子表格中。我加粗了所需的数据。

在下面的示例中， "-" 字符有助于Split功能不存在，If函数返回False。

  

“亲爱的先生/女士，我们希望确认 143.81 STG将提交到您指定的银行账户。这是您的索赔的全部和最终解决方案。   的 000001017671676
  JOHN SMITH代表公司。“