Outlook 2007 VBScript to save as .msg

Thanks so much! That's soooo helpful!!! :friends:

After I copied your code in and tried it to make sure it was working I did a couple of tweaks of my own.

1. I used a period instead of an underscore for
   Quote:

   ---

   sreplace = "."

   ---

2. I used an underscore instead of "--" in the statement:
   Quote:

   ---

   objItem.SaveAs myPath & "\" & strname & "_" & strdate & ".msg", olMSG

   ---

That gives me a filename more to my liking (e.g., "PRB000013662840_5.20.2011 10.27.17 AM.msg")

I may look for a way to remove that space between the date and time (maybe use an underscore there), and also between time and AM/PM (no space there).

Thanks again!
Dave

Could I lay a new challenge on ya? :D

Below is some code that allows us to "ReplyAll" *with* original attachments. Our support team needs to do this because we triage, create tickets, and reply to both the sender and the next team with the same ReplyAll message.

It would be greate to integrate this code with the SaveAsMsg code, with an additional tweak.

• After processing the "ReplyWithAttachments" code to create our container with all original attachments and recipients, would it be possible to kick off the SendAsMsg on the Send message event?

So, once you click "Send" button, the SaveAsMsg would process to create the copy of the sent message and save it to the location selected by the user.

• *And,* then it would be great if the email in the Sent Items folder could be *moved* to another folder (in this case a folder we have named "*Assigned Tickets").

Here then is the "ReplyWithAttachments" code that we'd like to integrate with the SaveAsMsg code.

[vba]
'<-- BEGIN REPLY WITH ATTACHMENTS -->
Sub ReplyWithAttachments()
' Keyboard Shortcut: Ctrl+w
Dim rpl As Outlook.MailItem
Dim itm As Object
Set itm = GetCurrentItem()
If Not itm Is Nothing Then
Set rpl = itm.ReplyAll
CopyAttachments itm, rpl
rpl.Display
End If

'Application_ItemSend (Item:=itm)
'Call RemoveRecipients(Item:=itm)
Set rpl = Nothing
Set itm = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub
'<-- END REPLY WITH ATTACHMENTS -->
[/vba]

Instead of [VBA]objItem.SaveAs myPath & "\" & strname & "_" & strdate & ".msg", olMSG[/VBA]try
[VBA]objItem.SaveAs myPath & "\" & strname & "_" & split(strdate," ")(0) & "_" & split(strdate," ")(1) & split(strdate," ")(2) & ".msg", olMSG[/VBA]Charlize

Quote:

---

Originally Posted by dbe4876

Thanks so much! That's soooo helpful!!! :friends:

After I copied your code in and tried it to make sure it was working I did a couple of tweaks of my own.

1. I used a period instead of an underscore for
2. I used an underscore instead of "--" in the statement:

That gives me a filename more to my liking (e.g., "PRB000013662840_5.20.2011 10.27.17 AM.msg")

I may look for a way to remove that space between the date and time (maybe use an underscore there), and also between time and AM/PM (no space there).

Thanks again!
Dave

---

Not sure, but why don't you create a rule that when a message is sent, certain actions need to perform. The problem is that the item_send stuff (thisoutlooksession) captures the email before it is actually sent. There isn't any sent time at that moment.

Charlize

ps. Or once a day clean up your sent items folder with an automation macro.

Anybody got a version of "SaveAsMsg" that does not present a dialog box? That just copies it to a folder you hard code in the script?

Hey, this script works fine by itself in my ThisOutlookSession General module. But, I have another script called ReplyWithAttachments in that module too. When I run the ReplyWithAttachments I break to code and it is highlights the "Option Explicit" line in your code. What do I need to do for these two sets of code to be happy with each other?

Quote:

---

Originally Posted by virtualburn

Charlize this works perfectly, I have removed some of the prompts and added a static root path for the location ~(S:\files\saved mail) etc.. I'm sure this thread will be of great benefit to other users as I found many incomplete solutions for this and no working scripts for Outlook 2007.

Thank you for your help.

Final Script[vba]Option Explicit
Public myPath As Variant
Sub SaveAsMSG()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Dim sreplace As String, mychar As Variant, strdate As String
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
strdate = objItem.ReceivedTime
sreplace = "_"
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
myPath = BrowseForFolder("P:\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & "\" & strname & "--" & strdate & ".msg", olMSG
End If
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function[/vba]

---

change this line[VBA]myPath = BrowseForFolder("P:\")[/VBA]in[VBA]myPath = "diskdriveletter:\directory"[/VBA]and the function BrowseForFolder will not be called.

You can only have one option explicit in a module. Just delete that line or put a ' in front of it.

And I would rewrite the saveasmsg procedure as a function or procedure so you could pass the mailitem that needs to be processed.

So itm in your code would be passed to [VBA]saveasmsg(itm)[/VBA] and the function is created as [VBA]function saveasmsg(objitem as outlook.mailitem, mypath as string)[/VBA]

Just an idea.

Charlize

Anybody know how to put a little confirmation dialog in this script that will act like an Outlook desktop alert? Something that will just appear for the time setup for Outlook alerts to say "Message Saved!" Something like that. I don't want to have to interact with it really, just see something that says it was copied/saved successfully, or if something prevented it that might say "Message Save Failed!"

If it fails I'll go looking for what might have happened. But, if successful then there's no need to click anything, just be informed.