Outlook 2007 VBScript to save as .msg

I have found various VB Scripts that perform a similar process but none of them work with Outlook 2007. I am sure I found one in the past that would save any message that was open to C:\ in the form of a .msg file if the macro was run.

What I am looking for is a a similar script that can be added to the ribbon so when an email is opened it can be run and the user is prompted for a destination folder, once chosen the mail will be saved as a .msg file.

I have searched high and low for this and really wish my VB skills were proficient enough for me to construct it myself but time constraints force me to shout for help.

Help!

..any pointers int he right direction or some assistance in writing such a Macro would be really appreciated.. cheers all. :D

I have actuallly found 2 VBScripts that will perform this function. The first shows a prompt to confirm the user wishes to save and then saves the email in C:\ as a /msg

[vba]Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs "C:\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub[/vba]
This next Script will do the same action although it still doesn't prompt for a location it will auto save in the location specified e.g C:\TEMP

[vba]Public Sub WhatEver()
'Dim Item As Object
Dim Mes As Object
'Set Mes = Application.ActiveInspector.CurrentItem
For Each Mes In Application.ActiveExplorer.Selection
SaveMailAsFile Mes, olMSG, "C:\TEMP\"
Next Mes
End Sub

Private Sub SaveMailAsFile(oMail As Outlook.MailItem, eType As OlSaveAsType, _
sPath As String)
Dim dtDate As Date
Dim sName As String
Dim sFile As String
Dim sExt As String

Select Case eType
'Select Case olMSG
Case 1
sExt = ".txt"
Case 2
' sExt = ".msg"
sExt = ".rtf"
Case 3
' sExt = ".rtf"
sExt = ".msg"
Case Else: Exit Sub
End Select

'sName = oMail.Subject
sName = oMail.SenderName & " - " & oMail.ReceivedTime & " - " & oMail.Subject
ReplaceCharsForFileName sName, "_"

'dtDate = oMail.ReceivedTime
'sName = Format(dtDate, "yyyymmdd-hh:nn am/pm") & "-" & sName & sExt


sName = sName & sExt
' oMail.SaveAs sPath & sName, eExt ' was eExt
oMail.SaveAs sPath & sName

'sName = InputBox("Enter the filename.", "Message File Name", oMail.Subject)
'ReplaceCharsForFileName sName, "_"
'sName = sName & sExt
'oMail.SaveAs sPath & sName


End Sub

Private Sub ReplaceCharsForFileName(sName As String, sChr As String)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, "Chr(34)", sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub[/vba]
Either of these scripts would be great, preferably the second but I want it to prompt for the location.

..also found this which is perfect apart from it doesn't work. The original site is here: [www]3rl.me[slash]87

I have found some lines which have drop down and screw up the code, could somebody just run through and check if there is anywhere else the lines have broken?

[vba]'-----CODE START-----
Public Sub ExportSAR()

Dim TheEmail As Object
Dim ReportEmail As ReportItem
Dim eItem As Outlook.Items
Dim EmailNS As NameSpace
Dim fldrCount, EmailPath2, NbrItem, myfolder
Dim strSubj, strTime, mailClassCheck, EmailPath As String
Dim NewFileName, ReportHeader As String
Dim Cats
Dim CheckErr, Exists As Boolean

CheckErr = False
Set EmailNS = Application.GetNamespace("MAPI")
Set myfolder = Application.ActiveExplorer.CurrentFolder
NbrItem = myfolder.Items.Count
On Error GoTo Error_Handler

EmailPath = BrowseForFolderShell
MsgBox EmailPath
'EmailPath = InputBox("Enter the save folder location:", "Email Save
Path", CurDir)
For i = 1 To NbrItem
Set TheEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
mailClassCheck = TheEmail.MessageClass
If Left(mailClassCheck, 6) = "REPORT" Then
Set ReportEmail =
Application.ActiveExplorer.CurrentFolder.Items.Item(i)
If ReportEmail.Subject = "" Then strSubj = "no subject"
If Right(ReportEmail.MessageClass, 2) = "DR" Then ReportHeader =
"DeliveryReport" Else ReportHeader = "Read Receipt"

strSubj = Replace(ReportEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(ReportEmail.CreationTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = ReportHeader & "_" & strSubj & strTime & ".msg"

If NewFileName <> "" Then
ReportEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64,
"Cancel Operation"
Exit Sub
End If
GoTo Step1
End If
If TheEmail.Subject = "" Then strSubj = "no subject"

strSubj = Replace(TheEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(TheEmail.ReceivedTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = TheEmail.SenderName & "_" & strTime & "_" & strSubj &
".msg"

If NewFileName <> "" Then
TheEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64,
"Cancel Operation"
Exit Sub
End If
Step1:
strSubj = ""
strTime = ""
Next i
GoTo Done

Error_Handler:
If TheEmail Is Nothing Then
MsgBox Err.Number & ":" & Err.Description Else
MsgBox TheEmail.MessageClass & Chr$(13) & TheEmail.Subject & Chr$(13) &
Err.Number & ": " & Err.Description
TheEmail.Categories = TheEmail.Categories & ";" & "Not Copied"
TheEmail.Save
End If
Resume Next

Done:
End Sub

Public Function BrowseForFolderShell(Optional Hwnd As Long = 0, Optional
sTitle As String = "Browse for Folder", Optional BIF_Options As Integer,
Optional vRootFolder As Variant) As String

Dim objShell As Object
Dim objFolder As Variant
Dim strFolderFullPath As String

Set objShell = CreateObject("Shell.Application") Set objFolder =
objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options, vRootFolder)

If (Not objFolder Is Nothing) Then
'// NB: If SpecFolder= 0 = Desktop then ....
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then strFolderFullPath =
CStr(objFolder): GoTo GotIt
On Error GoTo 0
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strFolderFullPath = objFolder.Items.Item.Path '&
Application.PathSeparator
Else
strFolderFullPath = objFolder.Items.Item.Path '& Application.
End If
Else
'// User cancelled
GoTo XitProperly
End If

GotIt:
BrowseForFolderShell = strFolderFullPath & "\"

XitProperly:
Set objFolder = Nothing
Set objShell = Nothing

End Function
'-----CODE END-----[/vba]

Try this one to select a directory where to save to :
[VBA]Option Explicit
Public myPath As Variant
Sub Choose_Directory_Or_Create_One()
'Dim mypath As Variant
myPath = BrowseForFolder("C:\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
MsgBox "Save to : " & myPath, vbInformation
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function[/VBA]
Put it in a separate private module (option private module) and call Choose_Directory_Or_Create_One from your code to perform the saving.

Charlize

Hi Charlize, thanks for your response.

I have added that as a seperate Module and added it to the Outlook ribbon and the message ribbon. Although it does ask me where to save no msg file appears in the location.

Also, it seem to default to the C:\ drive which is ok but I need to be able to select a Network location. Is it possible to have 'My Computer' as the default location when it opens the save dialogue?

EDIT: I changed the line myPath = BrowseForFolder("C:\") to myPath = BrowseForFolder("\\") and that enables me to choose network places, still not getting any file appear though.

Thanks again for your assistance. :D

Paste this coding in between Choose_Directory_Or_Create_One and the public var mypath. If you want a serveradress, you need to replace [vba]myPath = BrowseForFolder("C:\")[/vba]with[vba]myPath = BrowseForFolder("\\Name_of_Server\usershares\my_name")[/vba] ie. the name from the server and/or your folder wich is usually under usershares.
[vba]Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
call Choose_Directory_Or_Create_One
objItem.SaveAs mypath & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub[/vba]Charlize

Charlize, sorry for being such a Noob but the code I posted is not mine. Would it be possible to add your code to the existing code or just the call function as I wouldn't now where to start :s

Quote:

---

Originally Posted by virtualburn

Charlize, sorry for being such a Noob but the code I posted is not mine. Would it be possible to add your code to the existing code or just the call function as I wouldn't now where to start :s

---

Yes it could. Watch at the above posting. Added the call routine.

Charlize

So now I have this code as 'ThisOulookSession'

[VBA]'-----CODE START-----
Public Sub ExportSAR()

Dim TheEmail As Object
Dim ReportEmail As ReportItem
Dim eItem As Outlook.Items
Dim EmailNS As NameSpace
Dim fldrCount, EmailPath2, NbrItem, myfolder
Dim strSubj, strTime, mailClassCheck, EmailPath As String
Dim NewFileName, ReportHeader As String
Dim Cats
Dim CheckErr, Exists As Boolean

CheckErr = False
Set EmailNS = Application.GetNamespace("MAPI")
Set myfolder = Application.ActiveExplorer.CurrentFolder
NbrItem = myfolder.Items.Count
On Error GoTo Error_Handler

EmailPath = BrowseForFolderShell
MsgBox EmailPath
'EmailPath = InputBox("Enter the save folder location:", "Email Save Path ", CurDir)"
For i = 1 To NbrItem
Set TheEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
mailClassCheck = TheEmail.MessageClass
If Left(mailClassCheck, 6) = "REPORT" Then
Set ReportEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
If ReportEmail.Subject = "" Then strSubj = "no subject"
If Right(ReportEmail.MessageClass, 2) = "DR" Then
ReportHeader = "DeliveryReport"
Else
ReportHeader = "Read Receipt"

strSubj = Replace(ReportEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(ReportEmail.CreationTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = ReportHeader & "_" & strSubj & strTime & ".msg"

If NewFileName <> "" Then
ReportEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64, "Cancel Operation"
Exit Sub
End If
GoTo Step1
End If
If TheEmail.Subject = "" Then strSubj = "no subject"

strSubj = Replace(TheEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(TheEmail.ReceivedTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = TheEmail.SenderName & "_" & strTime & "_" & strSubj & ".msg"

If NewFileName <> "" Then
TheEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64, "Cancel Operation"
Exit Sub
End If
Step1:
strSubj = ""
strTime = ""
Next i
GoTo Done

Error_Handler:
If TheEmail Is Nothing Then
MsgBox Err.Number & ":" & Err.Description
Else
MsgBox TheEmail.MessageClass & Chr$(13) & TheEmail.Subject & Chr$(13) & Err.Number & ": " & Err.Description
TheEmail.Categories = TheEmail.Categories & ";" & "Not Copied"
TheEmail.Save
End If
Resume Next

Done:
End Sub

Public Function BrowseForFolderShell(Optional Hwnd As Long = 0, Optional sTitle As String = "Browse for Folder", Optional BIF_Options As Integer, Optional vRootFolder As Variant) As String

Dim objShell As Object
Dim objFolder As Variant
Dim strFolderFullPath As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options, vRootFolder)

If (Not objFolder Is Nothing) Then
'// NB: If SpecFolder= 0 = Desktop then ....
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then
strFolderFullPath = CStr(objFolder):
GoTo GotIt
On Error GoTo 0
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strFolderFullPath = objFolder.Items.Item.Path '&
Application.PathSeparator
Else
strFolderFullPath = objFolder.Items.Item.Path '& Application.
End If
Else
'// User cancelled
GoTo XitProperly
End If

GotIt:
BrowseForFolderShell = strFolderFullPath & "\"

XitProperly:
Set objFolder = Nothing
Set objShell = Nothing

End Function
'-----CODE END-----
[/VBA]#

This is 'Module1'

[VBA]Option Explicit
Public myPath As Variant
Sub Choose_Directory_Or_Create_One()
'Dim mypath As Variant
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
MsgBox "Save to : " & myPath, vbInformation
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function

[/VBA]

..and this is 'Module2'

[VBA]Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
Call Choose_Directory_Or_Create_One
objItem.SaveAs myPath & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
[/VBA]

Where do I add the the 'call' function to include your code? and what would I have to remove from the first code so it doesn't conflict with yours?

Thanks.

You don't have to put that code in the ThisOutlookSession. That's for special things you can do that have to be initialized when outlook starts. You want to save a message when you decide to do it. Put all the stuff i gave in one module and with your message open and active you use alt+F8 and run the macro (or put a button on the ribbon to call that macro). Just copy and past all this coding in one module. The macro to execute is SaveAsTXT. I hope it works out for you. Beware that there may only be one option explicit at the top. you can add Option Private Module beneath it so they can't see the macronames. If you use Alt+F8 and type in SaveAsTXT is will work if a mail is active (I hope).
[VBA]Option Explicit
Public myPath As Variant
Sub SaveAsTXT()
Dim myOlApp as object
Dim myItem As Outlook.Inspector
Dim objItem As Object
'not sure who wrote this but you are already in outlook
'and you have to declare myOlApp if you use it
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error Goto 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function[/VBA]Charlize

Final version since I couldn't edit previous post. Drop all this in a module and perform the macro SaveAsTXT
[VBA]Option Explicit
Option Private Module
Public myPath As Variant
Sub SaveAsTXT()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
strname = objItem.Subject
'Prompt the user for confirmation
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & "\" & strname & ".msg", olMSG
End If
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
[/VBA]Charlize

Morning Charlize, thank you for your hard work regarding this, it's certainly been a nice welcome to the Forum. I still have a couple of issues which I'm sure are because I'm still not sure what I'm doing.

If I copy the code into Module1 it doesn't appear in Macros when I try to add to the menu, only when I add the code into 'ThisOutlookSession' does it appear in Macros. Also When I add the code [below] I get an error in the old code I was using not your code.

Compile Error:
Next without For

I've highlighted the Error in RED
[VBA]
'-----START OLD CODE-----
Public Sub ExportSAR()

Dim TheEmail As Object
Dim ReportEmail As ReportItem
Dim eItem As Outlook.Items
Dim EmailNS As NameSpace
Dim fldrCount, EmailPath2, NbrItem, myfolder
Dim strSubj, strTime, mailClassCheck, EmailPath As String
Dim NewFileName, ReportHeader As String
Dim Cats
Dim CheckErr, Exists As Boolean

CheckErr = False
Set EmailNS = Application.GetNamespace("MAPI")
Set myfolder = Application.ActiveExplorer.CurrentFolder
NbrItem = myfolder.Items.Count
On Error GoTo Error_Handler

EmailPath = BrowseForFolderShell
MsgBox EmailPath
'EmailPath = InputBox("Enter the save folder location:", "Email Save Path ", CurDir)"
For i = 1 To NbrItem
Set TheEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
mailClassCheck = TheEmail.MessageClass
If Left(mailClassCheck, 6) = "REPORT" Then
Set ReportEmail = Application.ActiveExplorer.CurrentFolder.Items.Item(i)
If ReportEmail.Subject = "" Then strSubj = "no subject"
If Right(ReportEmail.MessageClass, 2) = "DR" Then
ReportHeader = "DeliveryReport"
Else
ReportHeader = "Read Receipt"

strSubj = Replace(ReportEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(ReportEmail.CreationTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = ReportHeader & "_" & strSubj & strTime & ".msg"

If NewFileName <> "" Then
ReportEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64, "Cancel Operation"
Exit Sub
End If
GoTo Step1
End If
If TheEmail.Subject = "" Then strSubj = "no subject"

strSubj = Replace(TheEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(TheEmail.ReceivedTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = TheEmail.SenderName & "_" & strTime & "_" & strSubj & ".msg"

If NewFileName <> "" Then
TheEmail.SaveAs EmailPath & NewFileName, olMSG
Else
MsgBox "No file name was entered. Operation aborted.", 64, "Cancel Operation"
Exit Sub
End If
Step1:
strSubj = ""
strTime = ""
Next i '<--[ THIS IS WHERE THE ERROR IS
GoTo Done

Error_Handler:
If TheEmail Is Nothing Then
MsgBox Err.Number & ":" & Err.Description
Else
MsgBox TheEmail.MessageClass & Chr$(13) & TheEmail.Subject & Chr$(13) & Err.Number & ": " & Err.Description
TheEmail.Categories = TheEmail.Categories & ";" & "Not Copied"
TheEmail.Save
End If
Resume Next

Done:
End Sub

Public Function BrowseForFolderShell(Optional Hwnd As Long = 0, Optional sTitle As String = "Browse for Folder", Optional BIF_Options As Integer, Optional vRootFolder As Variant) As String

Dim objShell As Object
Dim objFolder As Variant
Dim strFolderFullPath As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options, vRootFolder)

If (Not objFolder Is Nothing) Then
'// NB: If SpecFolder= 0 = Desktop then ....
On Error Resume Next
If IsError(objFolder.Items.Item.Path) Then
strFolderFullPath = CStr(objFolder):
GoTo GotIt
On Error GoTo 0
'// Is it the Root Dir?...if so change
If Len(objFolder.Items.Item.Path) > 3 Then
strFolderFullPath = objFolder.Items.Item.Path '&
Application.PathSeparator
Else
strFolderFullPath = objFolder.Items.Item.Path '& Application.
End If
Else
'// User cancelled
GoTo XitProperly
End If

GotIt:
BrowseForFolderShell = strFolderFullPath & "\"

XitProperly:
Set objFolder = Nothing
Set objShell = Nothing

End Function

'-----END OLD CODE-----

Option Explicit
Option Private Module
Public myPath As Variant
Sub SaveAsTXT()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
strname = objItem.Subject
'Prompt the user for confirmation
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & "\" & strname & ".msg", olMSG
End If
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
[/VBA]

You HAVE to put all this coding in a SEPARATE module. When you are in the vba editor, you can right click on the place where you see modules. Add one and put everything in it. If you want to see the macro names, you put a ' before option private module. You can't mix my code and the code you have. They are separate ideas. Haven't got any idea what your code does (not documented).
[vba]Option Explicit
'Option Private Module
Public myPath As Variant
Sub SaveAsTXT()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
strname = objItem.Subject
'Prompt the user for confirmation
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & "\" & strname & ".msg", olMSG
End If
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
[/vba]Charlize

ps. one thing left is the subject line. If it's empty, there will be an error. Also need to remove certain characters from a filename with replace ... But you can test it on a mail with a subject.

aah yes I see now that this is the complete code to perform the function. Thanks for the tip about 'Option Private Module

However, I run the module and it asks for the location when I try to save it brings up a 'Runtime Error Operation failed' when I debug it brings up this line

[VBA]objItem.SaveAs myPath & "\" & strname & ".msg", olMSG[/VBA]

Use F8 when in the editor on the coding and manually process it. Hover with your mouse around every possible variable and see if the tooltip provides you with a value. If strname is empty, it will give an error.

Charlize

ps.: I wrote it by using outlook 2007 and it worked fine (although not in a server environment. you do have the right to write to that folder on the network ?)

Ok I have tested on various emails and the script is working, but seems to error on any emails that have ':' or '/' in the message title. It does save message with 'RE:' in the title but the message is saved as 'RE' instead of 'RE: mail.msg'

I would presume this is why in the original code there were checks for replacing these characters if they existed in the title of the email

[VBA]If TheEmail.Subject = "" Then strSubj = "no subject"

strSubj = Replace(TheEmail.Subject, "/", "-")
strSubj = Replace(strSubj, "\", "-")
strSubj = Replace(strSubj, ":", "--")
strSubj = Replace(strSubj, "?", sReplace)
strSubj = Replace(strSubj, Chr(34), sReplace)
strSubj = Replace(strSubj, "<", sReplace)
strSubj = Replace(strSubj, ">", sReplace)
strSubj = Replace(strSubj, "|", sReplace)
strTime = Replace(TheEmail.ReceivedTime, "/", "-")
strTime = Replace(strTime, "\", "-")
strTime = Replace(strTime, ":", ".")
strTime = Replace(strTime, "?", sReplace)
strTime = Replace(strTime, Chr(34), sReplace)
strTime = Replace(strTime, "<", sReplace)
strTime = Replace(strTime, ">", sReplace)
strTime = Replace(strTime, "|", sReplace)
NewFileName = TheEmail.SenderName & "_" & strTime & "_" & strSubj & ".msg"

If NewFileName <> "" Then
TheEmail.SaveAs EmailPath & NewFileName, olMSG[/VBA]

Could this check be included? If you make some tests you will maybe see the same issues

Try this. Off course that it can be made and I knew there would be problems with those characters. I thought that you could deal with that part. Anyway, here it goes :
[VBA]Option Explicit
'Option Private Module
Public myPath As Variant
Sub SaveAsTXT()
'the mail we want to process
Dim objItem As Outlook.MailItem
'question for saving, use subject to save
Dim strPrompt As String, strname As String
'variables for the replacement of illegal characters
Dim sreplace As String, mychar As Variant, strdate As String
'put active mail in this object holder
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
'check if it's an email
If objItem.Class = olMail Then
'check on subject
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
strdate = objItem.ReceivedTime
'define the character that will replace illegal characters
sreplace = "_"
'create an array to loop through illegal characters (saves lines)
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
'do the replacement for each character that's illegal
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
'Prompt the user for confirmation
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
'changed the "c:" with mypath. See if mypath has an ending \
'otherwise use application.pathseparator to get \
myPath = BrowseForFolder("\\")
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
objItem.SaveAs myPath & "\" & strname & "--" & strdate & ".msg", olMSG
End If
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
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:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function[/VBA]Charlize

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]

The above code is sweet! Could I ask for one tweak? I would like an If loop to test for something like "PRB000013656305" in the subject line (look for 15 chars always starting with "PRB"). If it exists, then use that only for the filename (e.g., PRB000013656305.msg). If not, then follow the present course of taking the full Subject line.

replace
[VBA]If objItem.subject <> vbNullString Then
strname = objItem.subject
Else
strname = "No_Subject"
End If[/VBA]
with
[VBA]If InStr(1, objitem.subject, "PRB") > 0 Then
strname = Mid(objitem.subject, InStr(1, objitem.subject, "PRB"), 15)
Else
strname = objitem.subject
End If[/VBA]Charlize

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.