Skip to content

Instantly share code, notes, and snippets.

@JonasPammer

JonasPammer/SaveEmailsAsMSG.vba

Last active October 23, 2023 14:45
Show Gist options
  • Save JonasPammer/8ab036ed28d668b83abdd3bdb4af8429 to your computer and use it in GitHub Desktop.
Save JonasPammer/8ab036ed28d668b83abdd3bdb4af8429 to your computer and use it in GitHub Desktop.
Download ZIP
Outlook VBA/OTM Macro to save every message in a selected folder as its own .msg
Raw
SaveEmailsAsMSG.vba
Sub SaveEmailsAsMSG()
Dim olApp As Object
Dim olNs As Object
Dim olFolder As Object
Dim olMail As Object
Dim olItem As Object
Dim olName As String
Dim olSubfolder As String
Dim saveFolderPath As String
' Specify the folder path where you want to save the .msg files
saveFolderPath = "D:\Mailverkehr"
Set olApp = Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.PickFolder ' This allows you to select the folder you want to export
If Not olFolder Is Nothing Then
ProcessFolder olFolder, saveFolderPath
End If
End Sub
Sub ProcessFolder(olFolder As Object, saveFolderPath As String)
Dim olMail As Object
Dim olName As String
Dim subfolderPath As String
For Each olItem In olFolder.Items
If TypeOf olItem Is MailItem Then
Set olMail = olItem
timestamp = Format(olMail.ReceivedTime, "yyyy-MM-dd.hh.mm.ss ")
' Sanitize the subject by replacing invalid characters with underscores
olName = timestamp & SanitizeFileName(olMail.Subject) & ".msg"
' Create the subfolders if they don't exist
subfolderPath = CreateFolders(saveFolderPath & Replace(olFolder.folderPath, "\\", "\"))
If Len(subfolderPath) > 255 Then
AppendToLogFile "Subfolder Path itself already too long. very bad"
Err.Raise Number:=11, Description:="Subfolder Path itself already too long. very bad" & subfolderPath
End If
If Len(subfolderPath & olName) > 255 Then
AppendToLogFile "Cutting filename (too long): " & olName
olName = Left(olName, 255 - Len(subfolderPath) - Len(".msg")) & ".msg"
End If
' Check if the file already exists before saving
If Len(Dir(subfolderPath & olName)) = 0 Then
' Save the .msg file
olMail.SaveAs subfolderPath & olName, olMSG
AppendToLogFile "Saved: " & subfolderPath & olName
Else
AppendToLogFile "Skipped (already exists): " & subfolderPath & olName
End If
End If
Next olItem
' Process subfolders
If olFolder.folders.Count > 0 Then
Dim subfolder As Object
For Each subfolder In olFolder.folders
ProcessFolder subfolder, saveFolderPath
Next subfolder
End If
End Sub
Function SanitizeFileName(inputString As String) As String
Dim i As Integer
Dim invalidChars As String
Dim illegalChars() As String
Dim result As String
' Define the list of characters not allowed in filenames
invalidChars = "\/:*?""<>|"
' Create an array of illegal characters
illegalChars = Split(invalidChars, "")
' Initialize the result string
result = inputString
' Loop through each illegal character and replace it with an underscore
For i = 1 To Len(inputString)
If InStr(1, invalidChars, Mid(inputString, i, 1)) > 0 Then
result = Replace(result, Mid(inputString, i, 1), "_")
End If
Next i
' Remove any leading or trailing spaces
result = Trim(result)
' Ensure the resulting string is not too long (max length for a filename depends on the OS)
If Len(result) > 255 Then
result = Left(result, 255)
End If
SanitizeFileName = result
End Function
Function CreateFolders(path As String)
Dim folderPath As String
Dim folders() As String
Dim i As Integer
folders = Split(path, "\")
folderPath = ""
For i = LBound(folders) To UBound(folders)
If i = 0 Then
' Don't sanitize the drive letter portion
folderPath = folders(i) & "\"
Else
' Sanitize each folder name to replace illegal characters
folders(i) = SanitizeFileName(folders(i))
folderPath = folderPath & folders(i) & "\"
End If
If i > 0 And Len(Dir(folderPath, vbDirectory)) = 0 Then
MkDir folderPath
AppendToLogFile "Created folder: " & folderPath
End If
Next i
CreateFolders = folderPath
End Function
Sub AppendToLogFile(inputString As String)
Dim filePath As String
Dim fileNumber As Integer
' Define the file path
filePath = "D:\Log.txt"
' Open the file for appending
fileNumber = FreeFile
Open filePath For Append As fileNumber
' Write the inputString to the file
Print #fileNumber, inputString
' Close the file
Close #fileNumber
End Sub
Raw
Z-README.md

I was tasked to save an outlook folder of a leaving colleague and he didn't want it in a normal export (.pst). The only given requirement was that the folder structure was kept.

Because I've manually counted the E-Mails to be over 1000 I've went and created my first Outlook Macro :). I've never coded in Visual Basic, so I used the free version of ChatGPT. It still needed much re-input as well as changes by myself for the edge cases, also the sanitization and recurse it originally implemented didn't work. But all in all I'm amazed at how much time it saved me for dealing with this one off task. Loved the Questionare I was able to do for general questions. In the end it was done in 2-4 hours of fun coding time.

To check the result i also quickly GPT-generated this macro:

' ChatGPT Generated
Sub CountEmailsInFolder()
    Dim folder As Outlook.MAPIFolder
    Dim emailCount As Long

    ' Prompt the user to select a folder
    On Error Resume Next
    Set folder = Application.GetNamespace("MAPI").PickFolder
    On Error GoTo 0

    If Not folder Is Nothing Then
        emailCount = CountEmails(folder)
        MsgBox "Total emails in folder and subfolders: " & emailCount
    Else
        MsgBox "No folder selected."
    End If
End Sub

Function CountEmails(folder As Outlook.MAPIFolder) As Long
    Dim email As Object
    Dim subfolder As Outlook.MAPIFolder
    Dim count As Long

    count = folder.Items.count

    If folder.folders.count > 0 Then
        For Each subfolder In folder.folders
            count = count + CountEmails(subfolder)
        Next subfolder
    End If

    CountEmails = count
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment