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(Rep lace(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"