Export Macro Stops due to File Path being too Long

[Bob Phillips]

Before I try and combine them, I have given your code a general tidy-up. I presume it won't solve the problem, but can you just give it a quick try and see?

Sub EmailExport()
Dim myolApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim mail As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim aItem As Object
Dim timestamp As String
Dim path As String, filename As String
Dim iItemsUpdated As Long
Dim i As Long, j As Long, z As Long, q As Long
Dim total_messages, message_index, oMessage

    Set myolApp = CreateObject("Outlook.Application")
    Set mail = myolApp.ActiveExplorer.CurrentFolder
    iItemsUpdated = 0

    Set objNS = GetNamespace("MAPI")
    Set objFolder = objNS.Folders.GetFirst ' folders of your current account
    Set objFolder = objNS.Folders("SWN")
    Set objFolder = objFolder.Folders("SK2") ' parent folder
    Debug.Print (objFolder.Name)
    
    For Each aItem In objFolder.Items
    
        i = InStr(2, aItem.ReceivedTime, "/")
        j = InStr(i + 1, aItem.ReceivedTime, "/")

        With aItem
        
            timestamp = Format(.ReceivedTime, "yyyy-mm-dd hh-mm-ss")
        
            .Subject = ValidChars(.Subject)
            .Save
        
            If TypeName(aItem) = "MailItem" Then
            
                ' change C:\Users\stuebing_z\Desktop\test2\ to where you want to export emails
                path = CreateObject("WScript.Shell").SpecialFolders("DeskTop")
                filename = "General Communication_" & .Subject & " " & timestamp & ".msg"
                .SaveAs path & filename
            End If
        End With
    Next

    total_messages = objFolder.Items.Count
    For i = 1 To total_messages
    
        message_index = total_messages - i + 1
        Set oMessage = objFolder.Items.Item(message_index)
        oMessage.Delete
        Set oMessage = Nothing
    Next
End Sub

Function ValidChars(ByVal Inp As String) As String
Dim RegEx As Object

    Set RegEx = CreateObject("VBScript.RegExp")
    RegEx.Pattern = "[\\/:\*\?""<>\|,><]"
    RegEx.Global = True
    ValidChars = Replace(RegEx.Replace(Inp, ""), "  ", " ")
    Set RegEx = Nothing
End Function