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

【问题标题】：Outlook vba developer reading message body from forwarded messagesOutlook vba 开发人员从转发的邮件中读取邮件正文
【发布时间】：2015-02-08 16:01:27
【问题描述】：

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

结束子

【问题讨论】：

什么时候运行脚本？你可以再详细一点吗？您是否尝试在手动针对转发的电子邮件运行脚本时调试代码？

标签： vba outlook

【解决方案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))

【讨论】：