Public Sub AttachmentIndex()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
         
    Dim sAppName As String
    Dim sSection As String
    Dim sKey As String
    Dim lRegValue As Long
    Dim lFormValue As Long
    Dim iDefault As Integer
     
' HKCU\Software\VB and VBA Program Settings\Outlook\Index
    sAppName = "Outlook"
    sSection = "Index"
    sKey = "Last Index Number"
 ' The default starting number.
     iDefault = 101 ' adjust as needed
  
 ' Get stored registry value, if any.
     lRegValue = GetSetting(sAppName, sSection, sKey, iDefault)
  
 ' If the result is 0, set to default value.
     If lRegValue = 0 Then lRegValue = iDefault
 
    ' Get the path to your My Documents folder
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
 
    Set objOL = Application
    Set objSelection = objOL.ActiveExplorer.Selection
 
' The attachment folder needs to exist
' You can change this to another folder name of your choice
 
    strFolderpath = strFolderpath & "\OLAttachments\"
 
    For Each objMsg In objSelection
 
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
         
    If lngCount > 0 Then
    For i = lngCount To 1 Step -1
     
' Get the file name.
    strFile = objAttachments.Item(i).fileName
    
    lcount = InStrRev(strFile, ".") - 1
    pre = Left(strFile, lcount)
    ext = Right(strFile, Len(strFile) - lcount)
 
    ' Combine with the path to make the final path
    strFile = strFolderpath & pre & "_" & lRegValue & ext

    objAttachments.Item(i).SaveAsFile strFile
  
    lRegValue = lRegValue + 1
        Err.Clear
    Next
     
   ' Increment and update invoice number at the end
     SaveSetting sAppName, sSection, sKey, lRegValue
 
    End If
     
    Next
    
ExitSub:
   
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

End Sub