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))