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