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

End Sub

Answer 1

看起来你的行由标签后跟变量文本组成。这里描述了从结构化块解析文本的方法。

17.2 Parsing text from a message body

该示例查找与标签＆＃34;电子邮件：＆＃34;

相关联的文本

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

Outlook vba开发人员从转发的邮件中读取邮件正文

1 个答案: