Question

我有以下Outlook VBA代码将所选电子邮件的正文复制到Windows剪贴板：

Sub CopyMailToClipboard()
On Error GoTo HandleErr
'Copies the selected message to the Clipboard

    Dim M As MailItem
    Set M = ActiveExplorer().Selection.Item(1)

    modClipboard.gfClipBoard_SetData Replace(M.Body, vbCrLf & vbCrLf, vbCrLf)

ExitHere:
    Set M = Nothing
    Exit Sub

HandleErr:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , _
     "CopyMailToClipboard"
    Resume ExitHere
End Sub

此代码复制整个邮件正文，包括电子邮件会话中之前的所有回复。有时我只想复制最近的回复，而不是整个消息：

Outlook似乎知道邮件的分割位置，由分隔每个先前回复的灰线下方显示的Next和Previous按钮证明。

如何使用VBA仅在对话中将最近的回复复制到剪贴板？

我正在使用Outlook 2013和2016。

Answer 1

Outlook对象模型显然没有公开用于区分单个电子邮件正文中的各个邮件的机制。相反，我使用Split()函数来破解文本From:上的消息：

Sub CopyMailToClipboard(NumMessages As Integer)
On Error GoTo HandleErr
'Copies the selected message to the Clipboard
'NumMessages = Number of messages to return.  Use -1 to return all messages, 1 to return first (most recent)
'               message and so on.


    Dim M As MailItem
    Dim strMyString As String
    Dim strArrMessages() As String
    Dim varMessage As Variant
    Dim i As Integer
    Dim bolIsFirstMessage As Boolean

    Set M = ActiveExplorer().Selection.Item(1)
    strArrMessages() = Split(M.Body, "From: ")     'Split message body into an strArrMessagesay at each occurrance of "From: "
    i = NumMessages     'Set a counter to stop For Each loop when desired # of messages have been returned
    bolIsFirstMessage = True

    For Each varMessage In strArrMessages()
        If i = 0 Then Exit For      'Stop getting messages once i counter reaches 0.  This never triggers
                                    'if numMessages (and therefore i) start at -1, in which case we want
                                    'all messages

        If bolIsFirstMessage Then
            'Add header info to most recent message in thread
            strMyString = "From: " & M.Sender & vbCrLf & _
                "Sent: " & Format(M.SentOn, "dddd, mmmm dd, yyyy h:mm AM/PM") & vbCrLf & _
                "To: " & M.To & vbCrLf & _
                "Subject: " & M.Subject & vbCrLf & _
                vbCrLf & _
                Replace(varMessage, vbCrLf & vbCrLf, vbCrLf)

            bolIsFirstMessage = False

        Else
            strMyString = strMyString & _
                "-------------------------------------------------------------" & vbCrLf & _
                vbCrLf & "From: " & Replace(varMessage, vbCrLf & vbCrLf, vbCrLf)
                'Add the 'From: ' text removed by use of Split()

        End If

        i = i - 1

    Next varMessage

    'Put data on Clipboard
    modClipboard.gfClipBoard_SetData MyString:=strMyString

ExitHere:
    Set M = Nothing
    Exit Sub

HandleErr:
    MsgBox "Error " & Err.Number & ": " & Err.Description, , _
     "CopyMailToClipboard"
    Resume ExitHere
End Sub

仅复制对话中最近的回复到剪贴板

1 个答案: