Extract values of email fields, and place values in clipboard

[acantor]

I want to extract the To, CC, Subject, and Sent fields of an email message, and place the values in the Clipboard with a separator between each value. (Time will tell which separator will work best. Maybe Tab or New Line, but I will cross that bridge when I come to it.)

I am hoping the Clipboard will end up looking like this, assuming XXX is the separator in this example:

To: Sandy Smith (ssmith@email.com) XXXCc: XXXSubject: This is a test XXXSent: 09-Mar-2014 13:25

Help in coding this will be greatly appreciated.

[westconn1]

Set myItem = ActiveInspector.CurrentItem

s = "!" ' separator
For Each r In myItem.Recipients
If myItem.To = r.Name Then e = r.Address
Next
s = "!"
With myItem
mystr = "To:" & .To & "(" & e & ")" & s & "CC:" & .CC & s & "Subject:" & .Subject & s & "Sent:" & .SentOn
End With

depending what version you are using you may be able to use the office clipboard, or add a msforms dataobject and use that to putintoclipboard

if other options do not suit, i have posted a clipboard activex (and instructions)

http://www.vbforums.com/showthread.php?t=585616
download and register
continuing from above

set myclip = createobject("clipbrd.clipboard")
myclip.clear
myclip.settext mystr
set myclip = nothing

[acantor]

Your code sample kept me occupied for hours! I appreciate your help.

Now that I have worked on the problem longer, I am starting to get close to a complete solution.

The purpose of the script is to construct a version of a message in the clipboard that includes key fields, and uses only text that a user has selected in the body as the message text. It mostly works. Details of what is still not working, or not working as I envision, are in the comments.



Sub ExtractDataFromMessageAndReconstruct()

' The purpose of this script is to extract key fields from an Outlook email,
' and reconstruct them in the clipboard in a format that resembles the original message.
' Any text that the user has selected in the body becomes the entire body of the
' reconstructed message.

'From: aaa@xxx.com
'To: bbb@xxx.com
'CC: ccc@xxx.com
'BCC: ddd@xxx.com
'Subject: This is the subject line
'Sent: 11 March 2014 10:30 PM
'
'This is the selected text in the message.

Dim Body, FromLine, SentLine, ToLine, CCLine, BCCLine, SubjectLine, AttachmentLine, ReconstructedEmail As String

' To begin, I select text in the message body. When the script is activated,
' I want the text to become a string variable.
' I have not figured out how to do this. In Word VBA, I would do this:
'
' Let Body = Selection
'
' But this does not work in Outlook.

Let Body = ????

Set myItem = ActiveInspector.CurrentItem

' I don’t understand what the next three lines do, but the script seems to work without.

' For Each r In myItem.Recipients
' If myItem.To = r.Name Then e = r.Address
' Next

' To format the reconstructed email message, I use tabs and new lines:

NewLine = Chr$(13)
TabStop = Chr$(9)

' I define each line of the reconstructed message based on text extracted from a field:

FromLine = "From:" & TabStop & myItem.Sender & NewLine
ToLine = "To:" & TabStop & myItem.To & NewLine
CCLine = "CC:" & TabStop & myItem.CC & NewLine
BCCLine = "BCC:" & TabStop & myItem.BCC & NewLine
SubjectLine = "Subject:" & TabStop & myItem.Subject & NewLine
SentLine = "Sent: " & TabStop & myItem.SentOn & NewLine

' Is there a way to force .SentOn to display the day of the week? Or to round the time to the nearest minute?

' I also want to extract the names of any attachments, but this does not work:

' AttachmentLine = "Attachment: " & myItem.Attachments & NewLine

‘ If certain fields are empty, I want to exclude them from the reconstructed message.
‘ The third If statement doesn’t work, probably for the same reason as AttachmentLine (above) fails.

If myItem.CC = "" Then CCLine = ""
If myItem.BCC = "" Then BCCLine = ""
' If myItem.Attachments = "" Then AttachmentLine = ""

ReconstructedEmail = FromLine & ToLine & CCLine & BCCLine & SubjectLine & SentLine & NewLine & Body

' Put the reconstructed email into the clipboard:

Dim DataObj As New MSForms.DataObject
DataObj.SetText ReconstructedEmail
DataObj.PutInClipboard

End Sub

[westconn1]

' I don’t understand what the next three lines do, but the script seems to work without.

' For Each r In myItem.Recipients
' If myItem.To = r.Name Then e = r.Address
' Next
they get the email address of the recipient from the recipients name in the .To field, as To: Sandy Smith (ssmith@email.com)
not required unless you want the email address of the recipient


' To begin, I select text in the message body. When the script is activated,
this would require the use of several API functions, as outlook has no provision to do as such



' I also want to extract the names of any attachments, but this does not work:
you would need to loop through all the attachments in the collection and add each name to the string

if myitem.attachments.count > 0 then
attachmentline = "Attachment: "
for each a in myitem
attachementline = attachmentline & " ; " a.displayname
next
attachmentline = attachmentline & vbnewline


NewLine = Chr$(13)
TabStop = Chr$(9) not required, use
vbcr (chr(13)), vblf (chr(10)), vbnewline (vbcrlf)(chr(13) & chr(10)) and vbtab (chr(9))



' Is there a way to force .SentOn to display the day of the week? Or to round the time to the nearest minute?

format(myitem.SentOn,"dddd dd/mm/yyyy hh:nn") change format as required

[acantor]

Thank you again for another helpful response. The script is getting better and better!

One perplexing problem remains: copying text, selected in an email message, into a string variable. Since this works in Word:

x = Selection

...I thought adding a reference to the Microsoft Word Object Library would be the ticket. But it did not help. I also tried variations I have used in the past with the selection object in Word, but to no avail.

I will open a new thread to continue asking about this, as the question no longer matches the title of this thread.

Alan

[westconn1]

One perplexing problem remains: copying text, selected in an email message, into a string variable.

try like

body = myItem.GetInspector.HTMLEditor.Selection.createRange.Text

[acantor]

I get an error message:

Run time error 91. Object variable or With Block variable is not set.

Here is the start of the macro:



Sub Test()

Dim FromLine, SentLine, ToLine, CCLine, BCCLine, SubjectLine, AttachmentLine, Body As String

Set myItem = ActiveInspector.CurrentItem

Body = myItem.GetInspector.HTMLEditor.Selection.createRange.Text

[westconn1]

the above works correctly for me
do you have some selected text in myitem?

what is the outlook setting for htmleditor on your machine?

msgbox typename(myitem.getinspector.htmleditor)

[acantor]

Text is selected in the body of the email message.

Your debugging aid yields "Nothing" when the message is HTML, Rich Text, or Plain Text.

[westconn1]

test this to see which editor is set as default

msgbox myitem.getinspector.editortypeshould show a number from 1 to 4

[acantor]

Anyway I test it, I get 4.

[westconn1]

your editor is set to Word,

as mine is not, i can not test
try like

Body = myItem.GetInspector.WordEditor.Application.Selection.Range.Text

[acantor]

Amazing! It works! Thank you!

Do you know of resources that describe the various editor types? I want the script to be usable on my other computers, some of which may have different editor settings.

I wasn't aware that I could chose different editors in Outlook. The setting must be buried deeply in the UI, because I haven't found it (yet).

Again, I appreciate your help in solving this puzzle.

[westconn1]

The setting must be buried deeply in the UI, because I haven't found it (yet).
menu > tools > options > mailformat

from help

Returns the OlEditorType constant (http://www.vbaexpress.com/forum/rerefVariablesConstantsInVBScript.htm) for this item: olEditorHTML(2), olEditorRTF(3), olEditorText(1), or olEditorWord(4).
Note The EditorType property is not affected when you merely access the Body (http://www.vbaexpress.com/forum/olproBody.htm) property of the item (as in MsgBox myItem.Body), but when you reset the Body property (as in myItem.Body = "This is a new body"), the EditorType reverts back to the user's default editor.


i would believe the only 2 that would be able to return the selection are htmleditor and wordeditor, both examples in this thread

[acantor]

After a lot of trial and error experimentation and tweaking, the macro is working beautifully. (The only part that still is not functional extracts the email address of the recipient from the recipients name in the .To field. The code has no effect that I can detect.)

The purpose of the script is to extract key fields from an Outlook email, and reconstruct them in the clipboard in a format that resembles the original message. Text that the user selected in the body becomes the entire body of the reconstructed message:

From: aaa@xxx.com
To: bbb@xxx.com
CC: ccc@xxx.com
BCC: ddd@xxx.com
Subject: This is the subject line
Sent: 24 March 2014 10:30 PM
Attachments: eeee.doc

This is the text the user selected in the message

--------

(The reconstructed message ends with a horizontal line.)

I am open to suggestions on improving the code.




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

[westconn1]

The only part that still is not functional extracts the email address of the recipient from the recipients name in the .To field. The code has no effect that I can detect.the variable e should contain the email address, but you are not including it in the toline.

similar for cc and bcc, both can contain multiple and need to be parsed to get email addresses for each

[acantor]

I just discovered a quirk. When the body of the email message contains an image (e.g., a logo), it appears as an attachment in the reconstructed message, e.g.,

Attachment: F51AE637-47JQ-81A6-91F8-487X8905Z452[89].png

I suppose it might be possible to filter out these kinds of attachments by excluding file names that are longer than, say, 40 characters and that contain no white spaces. But that would not be a pretty solution.

Any thoughts on an elegant solution? Is there a built-in way to differentiate a "real" attachment from an image embedded in the body of the message?