I have taken the code you posted at the start, I modified it thoroughly for my needs and I wanted to share it back to you.
I have even registered just so I could send this update... and thank you for that has been very useful to me.
Hope it helps, I do not have any problem with the export anymore (there were a lot at the start), but I can not guarantee that it is fullproof.
Code:
Option Explicit
'On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim strSubject
Dim strEmailName
Dim strFileName
Dim strReceived
Dim strCategory
Dim count
Dim strBaseFolderSave
Dim objFSO
Dim strSaveFolder
Dim ErrNum, ErrDesc
Dim strMsg, strErrMsg
Dim numEmailsToExport
Dim Errors()
Dim i, strI
'Outlook.OlSaveAsType, we use here only olMSG to save the messages in *.msg format (default):
Const olTXT = 0
Const olRTF = 1
Const olTemplate = 2
Const olMSG = 3
Const olDoc = 4
Const olHTML = 5
Const olVCard = 6
Const olVCal = 7
Const olICal = 8
Const olMSGUnicode = 9
'Number of digits for the number
Const lngSuffixNumDigits = 3
'Initialise the array of errors
ReDim Errors(-1)
'Initialise
numEmailsToExport = 0
'Const DefaultBaseFolderSave = "C:\Projects"
Const DefaultBaseFolderSave = "C:\temp\Emails"
'Folder to save the files into
strBaseFolderSave = InputBox("Folder to save the files into:", "Save Emails", DefaultBaseFolderSave)
If Len(Trim(strBaseFolderSave)) = 0 Then
WScript.Echo "Cancelled"
WScript.Quit(0)
End If
'Strip the last "\", it is just more readable later on in the code to have to concatenate the "\"
If Right(strBaseFolderSave, 1) = "\" Then strBaseFolderSave = Left(strBaseFolderSave, Len(strBaseFolderSave) - 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
' start outlook if not running, if running use current instance.
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
' login to outlook in case you aren't.
' myOlApp.Logon
Set ofChosenFolder = myNameSpace.PickFolder
numEmailsToExport = ofChosenFolder.Items.Count
count = 0
For Each myItem in ofChosenFolder.Items
'Set myItem = ofChosenFolder.Items(i)
'strReceived = ArrangedDate(myitem.ReceivedTime)
strReceived = FormatDateFile(myitem.ReceivedTime)
strSubject = myItem.Subject
'I don't like the idea of having commas in the folder name...
strCategory = CustomReplace(myItem.Categories, " *, *", "_")
'Subject
If Len(Trim(strSubject))= 0 then strSubject = "MissingSubject"
'Removes all characters but alphanumeric, "_" and "-" and replace " " with "_"
strEmailName = StripFileIllegalChar(strSubject)
'If the email name is empty, it can only be because of the stripping of the special characters
If Len(Trim(strEmailName))= 0 then strEmailName = "InvalidFormatSubject"
'Folder where we will save the files
strSaveFolder = strBaseFolderSave
'Un-comment the following if you want to use the category for folder...
' I for one do not care the least, but it was in the original code...
' 'Category
' If Len(Trim(strCategory))> 0 Then
' strSaveFolder = strBaseFolderSave & "\" & strCategory
' Else
' strSaveFolder = strBaseFolderSave & "\" & "NoCategory"
' End If
'Create the folder if it does not exist
If Not objFSO.FolderExists(strSaveFolder) then
objFSO.CreateFolder(strSaveFolder)
'wscript.echo strSaveFolder & " - Created"
End If
'Finally, the full file name
strFileName = strSaveFolder & "\" & strReceived & "_" & strEmailName & ".msg"
' 'Adding the number?
' If objFSO.FileExists(strFileName) Then
' strFileBaseName = fso.GetBaseName(strFileName)
' strFileExtensionName = fso.GetExtensionName(strFileName)
' strPath = fso.GetParentFolderName(strFileName)
' 'Add the digits if needed
' If lngSuffixNumDigits >= 0 Then
' i = 0
' Do
' i = i + 1
' strI = CStr(i)
' 'Pad the number
' If Len(strI) < lngSuffixNumDigits Then
' strI = String(lngSuffixNumDigits - Len(CStr(i)), "0") & CStr(i)
' End If
' strTmpFileName = strSaveFolder & "\" & strFileBaseName & " (" & strI & ")." & strFileExtensionName
' If Not fso.FileExists(strTmpFileName) Then
' strFileName = strTmpFileName
' Exit Do
' End If
' Loop
' End If
' End If
If Len(strFileName) > 256 then
ReDim Preserve Errors(UBound(Errors)+1)
Errors(UBound(Errors)) = strFileName & vbcrlf & "Path and filename too long, it has been truncated ."
strFileName = Left(strFileName, 250) & "_" & ".msg"
End If
'Save the file!
If Not Len(strFileName) > 256 then
On Error Resume Next
'Outlook.OlSaveAsType.olMSG = 3
Call myItem.SaveAs(strFileName, 3)
ErrNum = Err.Number: ErrDesc = Err.Description
On Error Goto 0
If ErrNum = 0 Then
count = count + 1
Else
ReDim Preserve Errors(UBound(Errors)+1)
Errors(UBound(Errors)) = ErrNum & ": " & ErrDesc & " - Email """ & myItem.Subject & """ received """ & myItem.ReceivedTime & " not saved!"
End If
'wscript.echo strFileName & vbcrlf
Else
ReDim Preserve Errors(UBound(Errors)+1)
Errors(UBound(Errors)) = strFileName & vbcrlf & "Path and filename too long."
' Call WScript.Echo(strFileName & vbcrlf & "Path and filename too long.")
End If
next 'Item in ofChosenFolder.Items
If count = 0 Then
strMsg = "No item exported, " & numEmailsToExport & " were expected."
ElseIf count = 1 Then
strMsg = count & " item exported, " & numEmailsToExport & " were expected."
ElseIf count > 1 Then
strMsg = count & " items exported, " & numEmailsToExport & " were expected."
End If
'Report the number of emails exported
'Call WScript.Echo(strMsg)
If UBound(Errors) < 0 Then
strMsg = strMsg & vbCrLf & "No Error in exporting the files."
Else
strMsg = strMsg & vbCrLf & vbCrLf & "There have been " & UBound(Errors) + 1 & " errors whilst exporting the files: " & vbCrLf
For Each strErrMsg in Errors
strMsg = strMsg & " - " & strErrMsg & vbCrLf
Next
End If
'Report the number of emails exported and errors
WScript.Echo strMsg
'Free the memory
Erase Errors
'Clean up
Set ofChosenFolder = Nothing
Set myNameSpace = Nothing
Set myOlApp = Nothing
Set objFSO = Nothing
'Just get out!!!
WScript.Quit(0)
'------------------------------------------------------------------------------------------
' FUNCTIONS
'------------------------------------------------------------------------------------------
Private Function StripFileIllegalChar(strInput)
'***************************************************
'Simple function that removes illegal file system
'characters.
'***************************************************
Dim RegX
Set RegX = New RegExp
'Old
'RegX.pattern = "[\" & chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
'Simple, extremely restrictive, but it does work: alphanum, accents and some characters are allowed
RegX.Pattern = "[^a-zA-Z0-9 _\(\)@-]"
'RegX.Pattern = "[^a-zA-Z0-9\" & chr(128) & "-\" & chr(165) & " _\(\)@-]"
' 'Better... but I did not get great results with that...
' 'Other names that are forbidden for files: AUX CLOCK$ COM0 COM1 COM2 COM3 COM4 COM5 COM6 COM7 COM8 COM9 CON LPT0 LPT1 LPT2 LPT3 LPT4 LPT5 LPT6 LPT7 LPT8 LPT9 NUL PRN
' 'Perhaps we should do something about that too...
' 'See http://en.wikipedia.org/wiki/Filename#Comparison_of_file_name_limitations for the allowed characters.
' RegX.Pattern = "[\" & Chr(1) & "-\" & Chr(31) & "\""\*\:\<\>\?\\\|\.]"
RegX.IgnoreCase = True
RegX.Global = True
StripFileIllegalChar = RegX.Replace(strInput, "")
Set RegX = Nothing
End Function 'StripFileIllegalChar
Private Function CustomReplace(strExpression, strFind, strReplace)
'***************************************************
'This function is to do a replace without having to declare a regex...
'***************************************************
Dim regEx
Dim patrn
Set regEx = New RegExp ' Create regular expression.
patrn = strFind
regEx.Pattern = patrn ' Set pattern.
regEx.IgnoreCase = True ' Make case insensitive.
CustomReplace = regEx.Replace(strExpression, strReplace)' Make replacement.
Set regEx = Nothing
End Function
Private Function PadNumber(numToPad, numDigits)
Dim strNumToPad
strNumToPad = CStr(numToPad)
'Pad the number
If Len(strNumToPad) < numDigits Then
PadNumber = Right(String(numDigits, "0") & strNumToPad, numDigits)
Else
PadNumber = strNumToPad
End If
End Function
Private Function FormatDateFile(strDateInput)
'***************************************************
' This is to have a simple date format for the file
'***************************************************
Dim strDate
strDate = Year(strDateInput) & PadNumber(Month(strDateInput), 2) & PadNumber(Day(strDateInput), 2) & "_" & PadNumber(Hour(strDateInput), 2) & PadNumber(Minute(strDateInput), 2) & PadNumber(Second(strDateInput), 2)
FormatDateFile = strDate
End Function 'FormatDateFile
Private Function ArrangedDate(strDateInput)
'***************************************************
'This function re-arranges the date data in order
'for it to display in chronilogical order in a
'sorted list in the file system. It also removes
'illegal file system characters and replaces them
'with dashes.
'Example:
'Input: 2/26/2004 7:07:33 AM
'Output: 2004-02-26_AM-07-07-33
'***************************************************
Dim strFullDate
Dim strFullTime
Dim strAMPM
Dim strTime
Dim strYear
Dim strMonthDay
Dim strMonth
Dim strDay
Dim strDate
Dim strDateTime
Dim RegX
If not Left(strDateInput, 2) = "10" Then
If not Left(strDateInput, 2) = "11" Then
If not Left(strDateInput, 2) = "12" Then
strDateInput = "0" & strDateInput
End If
End If
End If
strFullDate = Left(strDateInput, 10)
If Right(strFullDate, 1) = " " Then
strFullDate = Left(strDateInput, 9)
End If
strFullTime = Replace(strDateInput,strFullDate & " ","")
If Len(strFullTime) = 10 Then
strFullTime = "0" & strFullTime
End If
strAMPM = Right(strFullTime, 2)
strTime = strAMPM & "-" & Left(strFullTime, 8)
strYear = Right(strFullDate,4)
strMonthDay = Replace(strFullDate,"/" & strYear,"")
strMonth = Left(strMonthDay, 2)
strDay = Right(strMonthDay,len(strMonthDay)-3)
If len(strDay) = 1 Then
strDay = "0" & strDay
End If
strDate = strYear & "-" & strMonth & "-" & strDay
strDateTime = strDate & "_" & strTime
Set RegX = New RegExp
RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(strDateTime, "-")
Set RegX = nothing
End Function 'ArrangedDate
10-26-2007, 02:51 PM
Problem exporting Outlook messages
New code
Linear Mode
