Too Long Attachment Name Save Outlook VBA
The below error pops up when you try to save TOO LONG of a name for an attachment in Microsoft Outlook email to your folders.
Here's my workaround for run-time error -2147024893.
Public getextension2 As String
Sub GetSelectedItems()
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim individualitem As Outlook.MailItem
Dim oMail As Outlook.MailItem
Dim i As Double
Dim ii As Double
Dim iii As Double
Dim iiii As Double
Dim MsgTxt As String
Dim x As Long
'Get senders of selected emails
x = 1
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
i = myOlSel.Count
iii = 1
iiii = 1
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
' For mail item, use the SenderName property.
'set the path for where the attachments will be saved
'''''''''''''SELECT PATH AREA
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
xlObj.Visible = False
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Filters.Clear
.Title = "Choose a Folder path"
.AllowMultiSelect = False
.InitialFileName = "C:\Users\18622\OneDrive\Desktop\VBA Lessons\Funds\"
If .Show = True Then
strpath = .SelectedItems(1) & "\"
End If
End With
xlObj.Quit
Set xlObj = Nothing
'''''''''''''END SELECT PATH AREA
'if you want to include any attachments while saving the email too
If myOlSel.Item(x).Class = OlObjectClass.olMail Then
Set dicFileNames = CreateObject("Scripting.Dictionary")
'For x = 1 To myOlSel.Count 'new
'''''''''''''Save attachments
For Each individualitem In Application.ActiveExplorer.Selection
If TypeName(individualitem) = "MailItem" Then
For Each att In individualitem.Attachments
ii = individualitem.Attachments.Count 'newem
If Not dicFileNames.exists(att.FileName) Then
dicFileNames.Add att.FileName, 1
Else
dicFileNames(att.FileName) = dicFileNames(att.FileName) + 1
dicFileNames.Add att.FileName & iiii & iii, iii
End If
If iii = 1 Then
''''''''''''''MAKE FOLDER BASED on Path SELECTION if new iteration
MkDir strpath & iiii & "\"
zz = 1
''''''''''''''END FOLDER BASED on Path SELECTION
End If
iii = iii + 1
On Error GoTo errhandler
errhandler:
'MsgBox Err.Number
If Err.Number = -2147024893 Then
Call getextension(att.FileName)
att.SaveAsFile strpath & iiii & "\" & "too long name" & "." & getextension2
GoTo line33:
End If
att.SaveAsFile strpath & iiii & "\" & "Attachment " & iii - 1 & "_" & att.FileName
'''''''''''''Attachment saved from this email
line33:
Next att
End If
If zz <> 1 Then
MkDir strpath & iiii & "\"
End If
iii = 1
iiii = iiii + 1
'''''''''test if count of iteration of emails > selection count/leave Loop
If iiii > i Then
GoTo ending:
End If
''''NEXT Selected email/save attachments if didn't exit loop
Next individualitem
End If
ending:
iiii = 1
'''''''''''''''*************************
'''create a collection to add each email name/folder name as variable emailname
Dim dirCollection As Collection
Set dirCollection = New Collection
Dim dirCollection2 As Collection
Set dirCollection2 = New Collection
Dim dirCollection3 As Collection
Set dirCollection3 = New Collection
Dim dirCollection4 As Collection
Set dirCollection4 = New Collection
''''''''''''''''''''''''''*******************
Set dicFileNames = CreateObject("Scripting.Dictionary")
For Each individualitem In Application.ActiveExplorer.Selection
If TypeName(individualitem) = "MailItem" Then
emailname = InputBox("Set name for email")
individualitem.SaveAs strpath & iiii & "\" & emailname & ".msg"
iiii = iiii + 1
dirCollection.Add (emailname)
dirCollection2.Add (individualitem.SenderName)
dirCollection3.Add (individualitem.ReceivedTime)
dirCollection4.Add (individualitem.Subject)
End If
Next individualitem
End If
'rename folders;
'count the number of files in a folder (ignore - I have this commented out)
'Dim folderpath As String, path As String, count As Integer
'folderpath = "C:\Users\18622\OneDrive\Desktop\New folder\"
'Filename = Dir(folderpath)
'Do While Filename <> ""
'count = count + 1
'Filename = Dir()
'Loop
'MsgBox count
Dim xx As Double
Dim oFSO As Object
Dim folder As Object
Dim subfolders As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set folder = oFSO.GetFolder(strpath)
Set subfolders = folder.subfolders
xx = subfolders.Count
Set oFSO = Nothing
Set folder = Nothing
Set subfolders = Nothing
'release memory
Dim strOldDirName As String
Dim strNewDirName As String
Dim xy As Double
xy = 1
'''''''''''''''*************************
''''''''''''''''''''''''''*******************
Dim foldername As String
Do Until xy > dirCollection.Count
foldername = dirCollection(xy)
strOldDirName = strpath & xy & "\"
strNewDirName = strpath & dirCollection(xy) & "\"
Name strOldDirName As strNewDirName
xy = xy + 1
Loop
End Sub
Public Function getextension(ByRef cf As String) As String
Dim ct As String
Dim tmpstring() As String
ct = StrReverse(cf)
tmpstring = Split(ct, ".")
getextension2 = StrReverse(tmpstring(0))
End Function