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

Revisions

  1. JonasPammer revised this gist Oct 23, 2023. No changes.
  2. JonasPammer revised this gist Oct 23, 2023. 2 changed files with 0 additions and 0 deletions.
    0 0_SaveEmailsAsMSG.vba → SaveEmailsAsMSG.vba
    View file
    File renamed without changes.
    0 README.md → Z-README.md
    View file
    File renamed without changes.
  3. JonasPammer renamed this gist Oct 23, 2023. 1 changed file with 0 additions and 0 deletions.
    0 SaveEmailsAsMSG.vba → 0_SaveEmailsAsMSG.vba
    View file
    File renamed without changes.
  4. JonasPammer revised this gist Oct 23, 2023. 1 changed file with 2 additions and 3 deletions.
    5 changes: 2 additions & 3 deletions README.md
    View file
    Original file line number Diff line number Diff line change
    @@ -3,9 +3,8 @@ 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 very thankful for the easy ingenious baseplate.
    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:
  5. JonasPammer renamed this gist Oct 23, 2023. 1 changed file with 0 additions and 0 deletions.
    0 SaveEmailsAsMSG.OTM → SaveEmailsAsMSG.vba
    View file
    File renamed without changes.
  6. JonasPammer revised this gist Oct 23, 2023. 2 changed files with 39 additions and 34 deletions.
    33 changes: 0 additions & 33 deletions CountEmailsInFolder.OTM
    View file
    Original file line number Diff line number Diff line change
    @@ -1,33 +0,0 @@
    ' 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
    40 changes: 39 additions & 1 deletion README.md
    View file
    Original file line number Diff line number Diff line change
    @@ -6,4 +6,42 @@ 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 very thankful for the easy ingenious baseplate.
    In the end it was done in 2-4 hours of fun coding time.
    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:

    ```vba
    ' 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
    ```
  7. JonasPammer created this gist Oct 23, 2023.
    33 changes: 33 additions & 0 deletions CountEmailsInFolder.OTM
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,33 @@
    ' 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
    9 changes: 9 additions & 0 deletions README.md
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,9 @@
    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 very thankful for the easy ingenious baseplate.
    In the end it was done in 2-4 hours of fun coding time.
    148 changes: 148 additions & 0 deletions SaveEmailsAsMSG.OTM
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,148 @@
    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