Before I left on my trip through South America, I decided to clean up all my mailboxes (I never delete a mail) and organize all mails in different PSTs, one for every year. So, I decided to use the import and archiving function of Outlook.
Step 1 : import all mails from a PST to a bulk PST
Step 2 : archive all mails older than a certain date (eg 2005) to a dedicated PST
Step 3 : goto step 1
After an hour or so, I had 10 PST files, each containing all mails sent and received that year. I thought. Outlook had messed up bigtime, it worked for most, but there were still mails from 1999 in the PST of 2004 and vice versa. NOT GOOD. Because I was leaving on my trip, I forget about it, until today and needed a mail I sent in September 2006 and did not find it, because it was in a wrong PST file. Crap. Crap. Triple crap. So, I surfed the web a bit, found myself a program called MessageSave, which made it possible to copy the Outlook folder structure to a filesystem and then you can sort them out quite fast (find will do the job perfectly) and then recreate the PST files. Too bad, the program was expensive.
So, I decided to write it myself. After surfing some VBS sites for half an hour (I hate VB, but hey it was fast, included in Windows and up to the task, but I hadn't used it for 10 years) and writing code for another half hour, the program was finished and worked splendid. Now, it is dumping all PSTs to the filesystem, reoganize them and recreate PST files.
If you would ever need the code, here it is :
' ******************************************************
' Sync_outlook_filesystem.vbs
' Rez Kiyn
' ******************************************************
On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim objItem
Dim myFolder
Dim strSubject
Dim strName
Dim strFile
Dim strReceived
Dim strSavePath
Dim strSubFolder
Dim objFileSystem
Dim objOutputFile
Dim strOutputFile
strOutputFile = "./" & Split(WScript.ScriptName, ".")(0) & ".log"
'********************************************************************************************************************
' Initialisation
'********************************************************************************************************************
Set objFileSystem = CreateObject("Scripting.fileSystemObject")
Set objOutputFile = objFileSystem.CreateTextFile(strOutputFile, TRUE)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
WriteLog("Initialising synchronisation")
'********************************************************************************************************************
' Runtime parameters
'********************************************************************************************************************
WriteLog("Querying for runtime parameters")
Set ofChosenFolder = myNameSpace.PickFolder
strSavePath = InputBox("Please enter the path to save to", "Save Emails To:", "d:\Data\")
If not right(strSavePath,1) = "\" then
strSavePath = strSavePath & "\"
wscript.echo "You forgot a backslash at the end of your path." & vbcrlf & "But don't worry, I added one for you."
End If
strSaveFolder = Left(strSavePath, Len(strSavePath)-1)
WriteLog("Fetch mails from " & ofChosenFolder )
WriteLog("Saving mails to " & strSavePath )
'********************************************************************************************************************
' Start synchronisation
'********************************************************************************************************************
WriteLog("Starting synchronisation")
syncFolder strSavePath & StripIllegalChar(ofChosenFolder.Name), ofChosenFolder
'********************************************************************************************************************
' End synchronisation
'********************************************************************************************************************
MsgBox "Finished syncing", VBYesNo
WriteLog("Finished Syncing")
objOutputFile.Close
Set objFileSystem = Nothing
'********************************************************************************************************************
' Function to write log line to logfile
'********************************************************************************************************************
Function WriteLog(logLine)
objOutputFile.WriteLine(Date() & " " & Time() & " " & logLine)
End Function
'********************************************************************************************************************
' Function to sync a folder in outlook with the folder on the file system
'********************************************************************************************************************
Function syncFolder(strFSPath, myFolder)
Writelog("Syncing folder '" & myFolder & "' to path '" & strFSPath & "'")
If not right(strFSPath,1) = "\" then
strFSPath = strFSPath & "\"
End if
CreateDirectory strFSPath
Syncitems strFSPath , myFolder
j = 1
For each Folder in myFolder.Folders
set mySubFolder = myFolder.Folders(j)
SyncFolder strFSPath & StripIllegalChar(mySubFolder.Name), mySubFolder
j = j + 1
next
' syncItems strFSPath, myFolder
End Function
'********************************************************************************************************************
' Function to sync a directory contents in outlook with the contents on the file system
'********************************************************************************************************************
Function syncItems(strFSPath, myFolder)
i = 1
For each Item in myFolder.Items
Set myItem = myFolder.Items(i)
WriteLog("Found item '" & myItem & "' in folder '" & myFolder & "'")
strReceived = ArrangedDate(myitem.ReceivedTime)
strSender = StripIllegalChar(myItem.SenderName)
strSubject = myItem.Subject
strName = StripIllegalChar(strSubject)
strFile = strFSPath & strReceived & "_" & strSender & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
myItem.SaveAs strfile, 3
WriteLog("Saving item : " & myItem & " " & " in folder " & myFolder & " to " & strFile)
Else
WriteLog("Path and filename too long for " & strFile)
End If
i = i + 1
next
End Function
'********************************************************************************************************************
' Function to create a directory
'********************************************************************************************************************
Function CreateDirectory(strDirectory)
On Error Resume Next
If Not objFSO.FolderExists(strDirectory) then
objFSO.CreateFolder(strDirectory)
If Err Then
WriteLog("Error in CreateDirectory(" & strDirectory & ")")
End if
WriteLog("Creating directory : " & strDirectory)
Else
WriteLog("Not creating directory : " & strDirectory)
End if
End Function
'********************************************************************************************************************
'Simple function that removes illegal file system characters.
'********************************************************************************************************************
Function StripIllegalChar(strInput)
Set RegX = New RegExp
RegX.pattern = "[\" & chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(strInput, "")
Set RegX = nothing
End Function
'********************************************************************************************************************
'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
'********************************************************************************************************************
Function ArrangedDate(strDateInput)
Dim strDateTime
Dim RegX
Dim sDate
sDate = CDate(strDateInput)
strDateTime = Year(sDate) & "-" & Month(sDate) & "-" & Day(sDate) & "_" & Hour(sDate) & "-" & Minute(sDate) & "-" & Second(sDate)
Set RegX = New RegExp
RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(strDateTime, "-")
Set RegX = nothing
End Function
Posts
