Export Macro Stops due to File Path being too Long

[Outlk]

Hi all,

I have a macro that exports emails in a specific folder. The macro takes the subject line, adds a date and time stamp and then exports it. This has worked great thus far. Recently it started to error out and I have figured out the cause to be when the subject line is a bit longer, coupled with the file path length it errors out.

Here is my code:

        If TypeName(aItem) = "MailItem" Then
            path = "G:\Special\This_is_a_test_folder123\123\General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg"
            aItem.SaveAs (path)
            'Debug.Print Item.ConversationTopic
        End If
    Next

The problem email will not export. If I Shorten the file path to just "G:\Special" it works fine. I tried to google a solution but came up empty. I am wondering if anyone has any ideas?

Also I tried On Error Resume Next but the only issue I have is after the export, I then run the below code which deletes all of the emails:

    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

If I use "On Error Resume Next" the vba code will skip exporting the email with the issue but then the delete code will delete it. If someone knows a way to merge the export and delete code so that "On Error Resume Next" does not export or delete the problem email, that would be a good solution too!

Thanks!

[Bob Phillips]

I don't know that this is the problem, but you shouldn't put path in parentheses in the save command,

        aItem.SaveAs path

You could also try two variables

        If TypeName(aItem) = "MailItem" Then
            Path = "G:\Special\This_is_a_test_folder123\123\"
            Filename = "General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg"
            aItem.SaveAs Path & Filename
            'Debug.Print Item.ConversationTopic
        End If
    Next

[Outlk]

Hi! Thanks for the response. I should have mentioned I tried this first and it did not work.

[Bob Phillips]

Okay, just a couple of thoughts. I can't say I have ever come across this myself.

[Outlk]

Okay, just a couple of thoughts. I can't say I have ever come across this myself.

No problem, thank you for trying. Any ideas on how to merge the export and delete code? if I can at least do that then "On Error Resume Next" would suffice.

[Bob Phillips]

I think we need to see more code, where does aItem get set for example.

[Outlk]

I think we need to see more code, where does aItem get set for example.

Sure. Here is the full code:

Sub EmailExport()


    Dim myolApp As Outlook.Application
    Dim aItem As Object
    Set myolApp = CreateObject("Outlook.Application")
    Set mail = myolApp.ActiveExplorer.CurrentFolder
    Dim iItemsUpdated As Integer
    Dim strTemp As String
    Dim strFilenum As String
    iItemsUpdated = 0
    Dim xItem As Object
    Dim xNewSubject As String
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim path As String
    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)
'    Set objFolder = objFolder.Folders("Test2") ' subfolder.
'    Debug.Print (objFolder.Name)
    
    For Each aItem In objFolder.Items
    
    Dim mattcombine, mattyear, mattmonth, mattday As String
    Dim i, j As Integer
    
    i = InStr(2, aItem.ReceivedTime, "/")
    j = InStr(i + 1, aItem.ReceivedTime, "/")
    
'    MsgBox i & " and " & j


    mattyear = Mid(aItem.ReceivedTime, j + 1, 4)
'    MsgBox mattyear


    mattmonth = Left(aItem.ReceivedTime, i - 1)
    If Len(mattmonth) = 1 Then
        mattmonth = "0" & mattmonth
    End If
'   MsgBox mattmonth
    
    mattday = Mid(aItem.ReceivedTime, i + 1, j - i - 1)
'    MsgBox mattday
    If Len(mattday) = 1 Then
        mattday = "0" & mattday
    End If
    
'    MsgBox mattyear & "-" & mattmonth & "-" & mattday
    mattcombine = mattyear & "-" & mattmonth & "-" & mattday


'    MsgBox mattcombine


    Dim zachcombine, zachhour, zachminute, zachsecond, zacho As String
    Dim z, q As Integer
    
    z = InStr(2, aItem.ReceivedTime, ":")
    q = InStr(z + 1, aItem.ReceivedTime, ":")
    
'   MsgBox z & " and " & q
    
    zachhour = Mid(aItem.ReceivedTime, z - 2, 2)
'   MsgBox zachhour


    Dim hourspace
    hourspace = Left(zachhour, 1)
'    MsgBox hourspace
    
    If hourspace = " " Then
        zachhour = zachhour
    Else: zachhour = " " & zachhour
    End If
    
'    MsgBox zachhour


    zachminute = Mid(aItem.ReceivedTime, z + 1, 2)
'   MsgBox zachminute
    
    zachsecond = Mid(aItem.ReceivedTime, q + 1, 2)
'   MsgBox zachsecond
    
    zacho = Mid(aItem.ReceivedTime, q + 4, 2)
'   MsgBox zacho
    
    zachcombine = zachhour & "-" & zachminute & "-" & zachsecond & " " & zacho
'   MsgBox zachcombine
    
'   Removes special characters
        Set xMailItem = aItem
        With xMailItem
            xNewSubject = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(.Subject, "/", ""), ":", ""), ".", ""), "*", "") _
            , "|", ""), "", ""), "<", ""), ">", ""), "?", ""), ",", ""), Chr(34), "")
            .Subject = xNewSubject
            .Save
        End With
'   Exports
        If TypeName(aItem) = "MailItem" Then
'        On Error Resume Next  ' do not use as errord emails will still be deleted
            path = "G:\Special\This_is_a_test_folder123\123\General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg" ' change C:\Users\stuebing_z\Desktop\test2\ to where you want to export emails
'            path = "G:\Special\This_is_a_test_folder123\123\General Communication"
'            FileName = "General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg"
'            aItem.SaveAs path & FileName
            aItem.SaveAs (path)
            'Debug.Print Item.ConversationTopic
        End If
    Next
'   Deletes messages in folder
    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

Another possible solution would be to on error move the email to a subfolder in outlook.

[gmayor]

If the issue is that the subject is too long, shorten it to a length that doesn't cause the error e.g. as follows

Left(aItem.Subject, 10)

[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

[Paul_Hossler]

How long is ...

"G:\Special\This_is_a_test_folder123\123\General Communication" & aItem.Subject & " " & mattcombine & zachcombine & ".msg"