'Save Selected E-Mails As Outlook Msg Files
'
'This program saves selected Outlook Inbox e-mail items
'as Outlook Msg files in a user-specified location.
'The Msg file name is the same as the e-mail subject line cleaned
'of illegal characters by the function CleanString(strData).
'In this example program I have appended a random number To the Msg file
'name To prevent overwriting of existing like e-mail subject lines.
'MSDN SaveAs method web page
'http://msdn.microsoft.com/en-us/library/aa210279%28office.11%29.aspx
'Thanks to SS. Kanagal, Jr. for key ideas enabeling me to solve the problem.
Option Explicit
' Declare variables.
Dim objOutlook, objNamespace, objFolder
Dim strScriptPath, strScriptName, strScriptFolder, olMSG
Dim objItem, j, SelectionStringStartPos, lngCount, intAttach
Dim EMailSubjectString, SelectionString, TempSubjectString
Dim SaveAsFilePath, Results
'vbBinaryCompare = 0
'vbTextCompare = 1
Const olFolderInbox = 6
olMSG = 3
SelectionString = "FW: " 'String to look for in e-mail subject line
SaveAsFilePath = "C:\TMP\ZZZ\" 'Folder path to store e-mails
Randomize 'Initialize random number generator
' Determine local path.
strScriptPath = Wscript.ScriptFullName
strScriptName = Wscript.ScriptName
strScriptFolder = Left(strScriptPath, Len(strScriptPath) - Len(strScriptName) - 1)
' Retrieve Outlook Inbox folder.
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
' Enumerate messages in Inbox.
Results = "" 'Initialize debug text buffer (technically not needed)
lngCount = objFolder.Items.Count
For j = lngCount To 1 Step - 1
Set objItem = objFolder.Items(j)
EMailSubjectString = objFolder.Items(j)
SelectionStringStartPos = Instr(UCase(EMailSubjectString), SelectionString) 'Search for string
If SelectionStringStartPos > 0 Then 'E-Mail subject line contains selection string
TempSubjectString = CleanString(EMailSubjectString) 'Clean e-mail subject line of invalid characters, etc.
TempSubjectString = TempSubjectString & " (" & Int(100000*Rnd()) & ")" 'Create Msg file name
objFolder.Items(j).SaveAs SaveAsFilePath & TempSubjectString & ".Msg", olMSG 'Save the e-mail
Results = Results & TempSubjectString & vbCrLf 'Debug statement
End If
Next 'j
'Clean Up.
Set objOutlook = Nothing
Set objNamespace = Nothing
Set objFolder = Nothing
Set objItem = Nothing
Wscript.Echo Results 'Debug statement
Wscript.Quit
'################################################################
'This function cleans the e-mail subject of invalid or
'undesirable characters
'Source: http://www.outlookcode.com/codedetail_print.aspx?id=827
'################################################################
Function CleanString(strData)
'Replace invalid strings.
strData = Replace(strData, "´", "'")
strData = Replace(strData, "`", "'")
strData = Replace(strData, "{", "(")
strData = Replace(strData, "[", "(")
strData = Replace(strData, "]", ")")
strData = Replace(strData, "}", ")")
strData = Replace(strData, " ", " ") 'Replace two spaces with one space
strData = Replace(strData, " ", " ") 'Replace three spaces with one space
'Cut out invalid signs.
strData = Replace(strData, ": ", "_") 'Colan followded by a space
strData = Replace(strData, ":", "_") 'Colan with no space
strData = Replace(strData, "/", "_")
strData = Replace(strData, "\", "_")
strData = Replace(strData, "*", "_")
strData = Replace(strData, "?", "_")
strData = Replace(strData, """", "'")
strData = Replace(strData, "<", "_")
strData = Replace(strData, ">", "_")
strData = Replace(strData, "|", "_")
CleanString = Trim(strData)
End Function
'This program may be easily modified to save e-mails in other file format types such as:
'olDoc(4), olHTML(5), olMSG(3), olRTF(1), olTemplate(2), olTXT(0), olVCal(7), or olVCard(6)
'Other Outlook folders can be accessed using the appropriate constants such as:
'Const olFolderDeletedItems = 3
'Const olFolderOutbox = 4
'Const olFolderSentMail = 5
'Const olFolderInbox = 6
'Const olFolderDrafts = 16
'Const olFolderJunk = 23