Try this
This will automatically give you a file name with the subject, date and time, but let you change it if desired. Then it opens a standard file browser window to let you select a folder.
Sub SaveMessagetoFolder()
'Declarations
Dim myItem As Outlook.Inspector
Dim objItem As MailItem
Dim dlg As Office.FileDialog
Dim objOL As Outlook.Application
Dim objOLWindow As Object
Dim strFileName As String 'Filename to save message under
Dim strFrom As String
Dim objDate As String
Dim objSubject As String
Dim Path As String
'ErrorHandling
On Error Resume Next
'Instantiations
Set myolapp = CreateObject("Outlook.Application")
Set myItem = myolapp.ActiveInspector
Set objItem = myItem.CurrentItem
'Assign variables
strFileName = objItem.Subject
objDate = objItem.CreationTime
'Build the filepath & Clean invalid characters from filename
strFileName = strFileName & " " & objDate & ".msg"
strFileName = Replace(strFileName, ":", "_")
strFileName = Replace(strFileName, "/", "_")
10 strFileName = InputBox("What file name would you like to use?", "Enter a filename", strFileName)
If strFileName = "" Then Exit Sub
extension = Right(strFileName, 4)
'Check to see if filename has .msg extension
If extension <> ".msg" Then strFileName = strFileName & ".msg"
'Check for valid filename
If IsValidFileName(strFileName) = False Then
MsgBox "That is not a valid filename! Change or delete any /<>?\|*:' characters."
GoTo 10
End If
'Exit if filename is blank
If strFileName = "" Then Exit Sub
'Open Folder Dialog
Set dlg = FileDialog(msoFileDialogFolderPicker)
dlg.InitialFileName = Path
dlg.Show
If IsNull(dlg.SelectedItems.Item(1)) Then Exit Sub
Path = dlg.SelectedItems.Item(1) & "\" & strFileName
Set dlg = Nothing
If Len(Path) > 259 Then MsgBox "The file path and name are greater than 259 characters. Please use a shorter filename."
'If the file exists, ask to overwrite
If Dir(Path) = strFileName Then
Response = MsgBox("That file exists! Press OK to overwrite or Cancel.", 49, "File Exists")
If Response = 2 Then Exit Sub
End If
MsgBox Path
objItem.SaveAs Path, olMSG
'Check if file was saved
If Dir(Path) = "" Then
MsgBox "There was a problem saving the message.", 48, "Error"
Exit Sub
Else
MsgBox "Message saved."
End If
'Close objects
objItem.Close olSave
objOL.ActiveWindow
objOL = Nothing
End Sub
Public Function IsValidFileName(ByVal name As String) As Boolean
Dim I As Integer
Const sBadChar As String = "/<>?\|*:'"
IsValidFileName = True
For I = 1 To Len(sBadChar)
If InStr(name, Mid$(sBadChar, I, 1)) Then
IsValidFileName = False
Exit For
End If
Next
End Function
