Forward email as an .msg

[jpool]

Hi there,

I am wondering if it is possible, and if so how it might be done that i can select say one email, click a button and have it be attached as an .msg in a new email, and also do the same for multiple selections.

Kind of like the standard 'Forward Items' function in Outlook, that can forward multiple selected emails as .msg, but can you expand on it to also do it for one email?

Hope someone can help.

Thanks :)

[Charlize]

Hi there,

I am wondering if it is possible, and if so how it might be done that i can select say one email, click a button and have it be attached as an .msg in a new email, and also do the same for multiple selections.

Kind of like the standard 'Forward Items' function in Outlook, that can forward multiple selected emails as .msg, but can you expand on it to also do it for one email?

Hope someone can help.

Thanks :)You could give this a first try. Be sure that you only use this in the mailbox because no error checking if the selected item is a mail or not.
Sub attach_selected_mails_to_new_message()
'directory to save message that you want to attach
'to a new message
Dim vpath As String
'loop for the messages that are selected
Dim vloop As Long
'the filename of the message that has been saved
Dim vfilename As String
'the new message
Dim vmessage As Outlook.MailItem
'the path to save the selected messages to
vpath = "C:\Tempmail"
'are some messages selected
If ActiveExplorer.Selection.Count = 0 Then
If MsgBox("New mail without attachments ?", _
vbOKCancel, "Mail Message ...") = vbCancel Then
Exit Sub
Else
'if you said yes create new message without attachments
Set vmessage = Outlook.CreateItem(olMailItem)
End If
Else
'process the selected messages
For vloop = 1 To ActiveExplorer.Selection.Count
'first message in selection (additional check on mailitem ?)
Set vmessage = ActiveExplorer.Selection.item(vloop)
'save message as a msg file
vmessage.SaveAs Left(vpath & "\" & vloop & " - " & _
vmessage.SenderName & " - " & _
StripIllegalChar(vmessage.Subject), 250) & ".msg", olMSG
Next vloop
'create a new message to display
Set vmessage = Outlook.CreateItem(olMailItem)
'process the messages that you saved earlier
vfilename = Dir(vpath & "\*.*")
Do While vfilename <> ""
vmessage.Attachments.Add vpath & "\" & vfilename, olByValue, _
, Left(vfilename, 25)
vfilename = Dir
Loop
vfilename = Dir(vpath & "\*.*")
'remove the saved messages from your directory
Do While vfilename <> ""
Kill vpath & "\" & vfilename
vfilename = Dir
Loop
End If
'display the message
vmessage.Display
End Sub
Function StripIllegalChar(StrInput)
Dim RegX As Object
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(StrInput, "_")
ExitFunction:
Set RegX = Nothing
End Function
Charlize