Sub ExtractDataFromMessage()
' Add Reference to "Microsoft Forms 2.0 Object Library"
' If not available, find it by browsing to "c:\Windows\SysWOW64\FM20.DLL"
Dim FromLine, SentLine, ToLine, CCLine, BCCLine, SubjectLine, AttachmentLine, Body, SeparatorLine, ReconstructedMsg As String
Set myItem = ActiveInspector.CurrentItem
' Which Outlook editor is in use?
Select Case myItem.GetInspector.EditorType
Case "4" ' Word Editor
Body = myItem.GetInspector.WordEditor.Application.Selection.Range.Text
Case Else ' HTML editor
Body = myItem.GetInspector.HTMLEditor.Selection.createRange.Text
End Select
' Tidy the body text. (Optional)
Body = Trim(Body)
' Body = Replace(Body, vbCr & vbTab, vbCr) ' Get rid of each Tab at the start of a line
' Body = Replace(Body, vbTab, " ") ' Replace other Tab characters with a single space
' Body = Replace(Body, Chr(11), vbCr) ' Substitute Line feeds for CRs
' Body = Replace(Body, vbCr & vbCr & vbCr, vbCr & vbCr) ' Get rid of extra Line feeds
' Body = Replace(Body, " ", " ") ' Replace three spaces with one
' Body = Replace(Body, " ", " ") ' Replace two spaces with one
' Body = Replace(Body, "> ", "") ' Replace > + space with nothing
' Body = Replace(Body, Chr(145), Chr(39)) ' Replace single curly quotes (open)
' Body = Replace(Body, Chr(146), Chr(39)) ' Replace single curly quotes (close)
' Body = Replace(Body, Chr(147), Chr(34)) ' Replace double curly quotes (open)
' Body = Replace(Body, Chr(148), Chr(34)) ' Replace double curly quotes (close)
Body = Body & vbCr
' This section gets the email address of the recipient from the .To field:
' To: Sandy Smith (ssmith@email.com)
' It's not required unless you want the name and email address
For Each R In myItem.Recipients
If myItem.To = R.Name Then e = R.Address
Next
' If the message has no "From" (Sender) field, then this message has not been sent. There is no Sent date or From field.
If myItem.Sender Is Nothing Then
SentLine = ""
FromLine = ""
Else
SentLine = "Sent: " & vbTab & Format(myItem.SentOn, "ddd dd-Mmm-yyyy h:nn am/pm") & vbNewLine
FromLine = "From:" & vbTab & myItem.Sender & vbNewLine
End If
' All messages have To, CC, BCC, and Subject fields. Don't show the CC and BCC fields if they are blank
ToLine = "To:" & vbTab & myItem.To & vbNewLine
If myItem.CC = "" Then
CCLine = ""
Else
CCLine = "CC:" & vbTab & myItem.CC & vbNewLine
End If
If myItem.BCC = "" Then
BCCLine = ""
Else
BCCLine = "BCC:" & vbTab & myItem.BCC & vbNewLine
End If
' Tidy the To, CC, and BCC lines by deleting single quote marks
ToLine = Replace(ToLine, "'", "")
CCLine = Replace(CCLine, "'", "")
BCCLine = Replace(BCCLine, "'", "")
SubjectLine = "Subject:" & vbTab & myItem.Subject & vbNewLine
' Some messages may have attachments. Extract the file name(s)
If myItem.Attachments.Count > 0 Then
AttachmentLine = "Attachment:" & vbTab
For Each a In myItem.Attachments
AttachmentLine = AttachmentLine & a.DisplayName & " "
Next
AttachmentLine = RTrim(AttachmentLine) & vbNewLine & vbNewLine
Else
AttachmentLine = vbNewLine
End If
' After the body, insert a horizontal line and a couple of blank lines
SeparatorLine = "----------" & vbCr & vbCr
' Reconstruct the message
ReconstructedMsg = FromLine & SentLine & ToLine & CCLine & BCCLine & SubjectLine & AttachmentLine & Body & SeparatorLine
' Place the reconstructed message in the Clipboard
Dim DataObj As New MSForms.DataObject
DataObj.SetText ReconstructedMsg
DataObj.PutInClipboard
End Sub