Outlook 2007 VBScript to save as .msg

[virtualburn]

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.

[virtualburn]

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.

[virtualburn]

..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]

[Charlize]

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

[virtualburn]

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.

[Charlize]

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

[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

[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

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

Charlize

[virtualburn]

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.

[Charlize]

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

[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

[virtualburn]

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]

[Charlize]

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.

[virtualburn]

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]

[Charlize]

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 ?)

[virtualburn]

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

[Charlize]

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

[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]

[dbe4876]

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.

[Charlize]

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