The Excel VBA object model is awesome. Rich, detailed, and complete exposure to everything in a useful fashion. The Word VBA object model is all right. Things are there, but the event model is fairly poor. It works well enough. The PowerPoint Object Model has a distinctly tacked on feel, and rightly so… if you feel the need for anything other than simple scripting in PowerPoint, you’re probably using the wrong tool. The Outlook Object Model is weird.
I’m not complaining, mind you…. this is just an observation. I’m sure it’s a lack of familiarity. But… nothing was where I expected it to be. The model seems to be built around multiple sessions and windows, in a manner that is wildly opposed to the way I use Outlook. I’m sure there are reasons that justify it all, but… Golly Gosh Darn It.
Anyway, this script is being posted as a memo for me, showing how some things can be made to hang together. The script starts from an open folder, and then saves every mail item to a folder on the OS, mimicing the subfolders structure on the way. I don’t intend this as usable by anyone other that me… and 2009 Me at that. Hear that, Future Me? Look at my code structure, and despair.
Option Explicit
Private Const MyTitle As String = "Michael says..."
Private Const MyDocSubFolder = "Email Export"
Public Sub ExportFoldersToFileSystem()
Dim ROOT As MAPIFolder, FSO
Dim startPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ROOT = ActiveExplorer.currentFolder
startPath = getStartingPath(FSO)
Debug.Print "STARTING..."
Call SaveSubFolders(FSO, ROOT, startPath)
Debug.Print "ENDING..."
Set ROOT = Nothing
Set FSO = Nothing
End Sub
Private Function getStartingPath(givenFSO) As String
Dim SHELL
Set SHELL = CreateObject("WScript.Shell")
getStartingPath = SHELL.SpecialFolders("MyDocuments") & "\" & MyDocSubFolder
If givenFSO.FolderExists(getStartingPath) Then
givenFSO.DeleteFolder (getStartingPath)
End If
givenFSO.CreateFolder (getStartingPath)
Set SHELL = Nothing
End Function
Private Sub SaveSubFolders(givenFSO, givenFolder As MAPIFolder, currentPath As String)
Dim FLD As MAPIFolder, newPath As String
Call SaveCurrentFolder(givenFolder, currentPath)
For Each FLD In givenFolder.Folders
newPath = currentPath & "\" & makeSafe(FLD.Name)
givenFSO.CreateFolder (newPath)
Call SaveSubFolders(givenFSO, FLD, newPath)
Next FLD
End Sub
Private Sub SaveCurrentFolder(givenFolder As MAPIFolder, givenPath As String)
Dim currentMail As MailItem, currentnote As NoteItem
Select Case givenFolder.DefaultItemType
Case olMailItem
For Each currentMail In givenFolder.Items
Call SaveMailAttachments(currentMail, givenPath)
Call SaveMailItem(currentMail, givenPath)
Next currentMail
Case olNoteItem
For Each currentnote In givenFolder.Items
Call SaveNoteItem(currentnote, givenPath)
Next currentnote
Case Else
'MsgBox prompt:="File Export only provided for mail. " & Chr(10) & _
' " Cannot export " & givenFolder.Name, _
' buttons:=vbCritical + vbOKOnly, _
' Title:=MyTitle
Debug.Print "NO SAVE| Folder is not MailType folder. " & givenFolder.Name
End Select
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' SAVE MAIL FUNCTIONS
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SaveMailAttachments(givenMail As MailItem, saveTo As String)
Dim ATT As Attachment, newName As String
For Each ATT In givenMail.Attachments
newName = GetMailDateFormat(givenMail) & "-" & ATT.FileName
ATT.SaveAsFile (saveTo & "\" & newName)
Next ATT
End Sub
Private Sub SaveMailItem(givenMail As MailItem, saveTo As String)
givenMail.Display
givenMail.BodyFormat = olFormatPlain
'Debug.Print "SAVE TO| " & GetMailSavePath(givenMail, saveTo)
On Error GoTo SaveFail
givenMail.SaveAs Path:=GetMailSavePath(givenMail, saveTo), Type:=OlSaveAsType.olTXT ' GetMailSaveAsType(givenMail) 'givenMail.BodyFormat
On Error GoTo 0
'Debug.Print "!SAVED!| "
GoTo Finish
SaveFail:
Debug.Print "NO SAVE| " & givenMail.Subject & " ||# " & CStr(Err.Number) & " - " & Err.Description
Finish:
givenMail.Close olDiscard
End Sub
Private Function GetMailSaveAsType(givenMail As MailItem) As Integer
Select Case givenMail.BodyFormat
Case olFormatHTML
GetMailSaveAsType = OlSaveAsType.olHTML
Case olFormatPlain
GetMailSaveAsType = OlSaveAsType.olTXT
Case olFormatRichText
GetMailSaveAsType = OlSaveAsType.olRTF
Case Else
GetMailSaveAsType = OlSaveAsType.olMSG
Err.Raise 2, "Type not known for mail:" & givenMail.Subject
End Select
End Function
Private Function GetMailSavePath(givenMail As MailItem, givenPath As String)
Dim myExt
Select Case givenMail.BodyFormat
Case olFormatHTML
myExt = ".htm"
Case olFormatPlain
myExt = ".txt"
Case olFormatRichText
myExt = ".rtf"
Case Else
myExt = ""
Err.Raise 1, "Extension not known for mail:" & givenMail.Subject
End Select
myExt = ".txt"
GetMailSavePath = Trim(givenPath & "\" & GetMailName(givenMail) & myExt)
End Function
Private Function GetMailName(givenMail As MailItem) As String
GetMailName = makeSafe(Left(GetMailDateFormat(givenMail) & "-" & givenMail.Subject, 200))
End Function
Private Function GetMailDateFormat(givenMail As MailItem) As String
Dim mailDate As String, mailTime As String
mailDate = FormatDateTime(givenMail.ReceivedTime, vbShortDate)
mailTime = FormatDateTime(givenMail.ReceivedTime, vbShortTime)
GetMailDateFormat = makeSafe(mailDate & "-" & mailTime)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' NOTE ITEM FUNCTIONS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub SaveNoteItem(givenNote As NoteItem, givenPath As String)
givenNote.Display
On Error GoTo DidNotSave
givenNote.SaveAs givenPath & "\" & Left(makeSafe(givenNote.Subject), 50) & ".rtf", olRTF
On Error GoTo 0
GoTo Finish
DidNotSave:
Debug.Print "NOSAVE|" & givenNote.Subject
GoTo Finish
Finish:
givenNote.Close olDiscard
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' UTILITY FUNCTIONS
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function makeSafe(givenString As String, Optional safeChar As String = "_") As String
makeSafe = givenString
makeSafe = Replace(makeSafe, "\", safeChar)
makeSafe = Replace(makeSafe, "/", safeChar)
makeSafe = Replace(makeSafe, ":", safeChar)
makeSafe = Replace(makeSafe, "*", safeChar)
makeSafe = Replace(makeSafe, """", safeChar)
makeSafe = Replace(makeSafe, "<", safeChar)
makeSafe = Replace(makeSafe, ">", safeChar)
makeSafe = Replace(makeSafe, "|", safeChar)
makeSafe = Replace(makeSafe, ".", safeChar)
makeSafe = Replace(makeSafe, "?", safeChar)
End Function