Outlook vba开发者从转发邮件中阅读邮件正文

Question

我有一个Outlook的vba脚本，它读取关键字的电子邮件并将其输出到csv文件。该脚本的作用是查找电子邮件是否直接发给我，但如果脚本是来自朋友的转发邮件，则脚本会中断。任何帮助表示赞赏编辑脚本才能正常运行，当它被转发

Public Sub EidInfo(Item As Outlook.MailItem) 
Dim CurrentMessage As MailItem 
Dim MsgBody As String 
Dim SearchPos As String 
Dim SearchMsg(11) As String 
Dim SearchStr(11) As String 
Dim StartPos As Integer 
Dim EndPos As Integer 
Dim LineMsg As String 

Set CurrentMessage = Item 

MsgBody = CurrentMessage.HTMLBody 

SearchStr(1) = "Requester " 
SearchStr(2) = "Flight " 
SearchStr(3) = "Request Type:-" 
SearchStr(4) = "Summary : " 
SearchStr(5) = "Description : " 
SearchStr(6) = "Reason : " 
SearchStr(7) = "Number : " 
SearchStr(8) = "From Date : " 
SearchStr(9) = "To Date : " 
SearchStr(10) = "Number of Days : " 
SearchStr(11) = "Country : " 

EndPos = 1 

For i = 1 To 11 
    StartPos = InStr(EndPos, MsgBody, SearchStr(i), vbTextCompare) + Len(SearchStr(i)) 

    If i = 1 Then 
     EndPos = StartPos + 15 
    ElseIf i = 2 Then 
     EndPos = InStr(StartPos, MsgBody, ".", vbTextCompare) 
    ElseIf i = 11 Then 
     EndPos = InStr(StartPos, MsgBody, "<BR>", vbTextCompare) 
    Else 
     EndPos = InStr(StartPos, MsgBody, "<BR>" + SearchStr(i + 1), vbTextCompare) 
    End If 

    SearchMsg(i) = Mid(MsgBody, StartPos, EndPos - StartPos) 
    SearchMsg(i) = Replace(SearchMsg(i), "<BR>", " ") 
    SearchMsg(i) = Replace(SearchMsg(i), ",", ".") 
Next i 

If Dir("D:\EidFile.csv") = "" Then 
    Open "D:\EidFile.csv" For Output As #1 

    LineMsg = "Request Time," 

    For i = 1 To 11 
     LineMsg = LineMsg + Replace(SearchStr(i), ":", " ") 
     If i < 11 Then LineMsg = LineMsg + "," 
    Next i 

    Print #1, LineMsg 
    LineMsg = "" 
Else 
    Open "D:\EidFile.csv" For Append As #1 
End If 

LineMsg = CurrentMessage.ReceivedTime 
LineMsg = LineMsg + "," 

For i = 1 To 11 
    LineMsg = LineMsg + SearchMsg(i) 
    If i < 11 Then LineMsg = LineMsg + "," 
Next i 

Print #1, LineMsg 

Close #1 

末次

Answer 1

它看起来你有由标签，然后变量的文本行。这里描述了解析来自结构化块的文本的方法。

17.2 Parsing text from a message body

的例子查找与标签相关的文本 “电子邮件：”

Sub FwdSelToAddr() 
    Dim objOL As Outlook.Application 
    Dim objItem As Object 
    Dim objFwd As Outlook.MailItem 
    Dim strAddr As String 
    On Error Resume Next 
    Set objOL = Application 
    Set objItem = objOL.ActiveExplorer.Selection(1) 
    If Not objItem Is Nothing Then 
     strAddr = ParseTextLinePair(objItem.Body, "Email:") 
     If strAddr <> "" Then 
      Set objFwd = objItem.Forward 
      objFwd.To = strAddr 
      objFwd.Display 
     Else 
      MsgBox "Could not extract address from message." 
     End If 
    End If 
    Set objOL = Nothing 
    Set objItem = Nothing 
    Set objFwd = Nothing 
End Sub 

Function ParseTextLinePair _ 
    (strSource As String, strLabel As String) 
    Dim intLocLabel As Integer 
    Dim intLocCRLF As Integer 
    Dim intLenLabel As Integer 
    Dim strText As String 
    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) 
End Function 

你可能会使用这样的：

SearchMsg(i) = ParseTextLinePair(CurrentMessage.Body, SearchStr(i))