Option Explicit

Sub SavePDFAttachmentToDisk(Item As Outlook.MailItem)
'Use this macro as a script attached to a rule
Dim olkAttachment As Outlook.Attachment
Dim objFSO As Object
Dim strRootFolderPath As String
Dim strFilename As String
'Change the following path to match your environment
Const strRootFolderPath As String = "Y:\"
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Item.Attachments.Count > 0 Then
        For Each olkAttachment In Item.Attachments
            If objFSO.GetExtensionName(LCase(olkAttachment.Filename)) = "pdf" Then
                strFilename = strRootFolderPath & olkAttachment.Filename
                olkAttachment.SaveAsFile strFilename
            End If
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub SaveAttachmentsFromFolderToDisk(Item As Outlook.MailItem, strFolderPath As String)
'Use this macro to process the folders, called from ProcessFolder
Dim olkAttachment As Outlook.Attachment
Dim objFSO As Object
Dim strFilename As String

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If Item.Attachments.Count > 0 Then
        For Each olkAttachment In Item.Attachments
            If objFSO.GetExtensionName(LCase(olkAttachment.Filename)) = "pdf" Then
                strFilename = strFolderPath & olkAttachment.Filename
                olkAttachment.SaveAsFile strFilename
            End If
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
lbl_Exit:
    Exit Sub
End Sub

Sub ProcessFolder()
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Outlook.MailItem
Dim olItems As Outlook.Items
Dim olNS As Outlook.NameSpace
Dim i As Long
Dim oFrm As New frmProgress
Dim PortionDone As Double
Dim strFolder As String
Const strRootFolder As String = "Y:\"

    If Not FolderExists(strRootFolder) Then
        If Len(strRootFolder) = 3 Then
            MsgBox "The drive letter " & strRootFolder & " does not exist on this PC." & vbCr & vbCr & _
                   "Restore the drive and run the process again."
            GoTo lbl_Exit
        End If
    End If
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    strFolder = olFolder.Name

    If Not FolderExists(strRootFolder & strFolder) Then
        CreateFolders strRootFolder & strFolder
    End If
    Set olItems = olFolder.Items
    olItems.Sort "[Received]", True
    oFrm.Show vbModeless
    For i = 1 To olItems.Count
        Set olItem = olItems(i)
        PortionDone = i / olItems.Count
        oFrm.lblProgress.Width = oFrm.fmeProgress.Width * PortionDone
        oFrm.Caption = "Processing message " & i & " of " & olItems.Count
        SaveAttachmentsFromFolderToDisk olItem, strRootFolder & strFolder & "\"
        DoEvents
    Next i
    Unload oFrm
lbl_Exit:
    Exit Sub
End Sub

Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
    On Error GoTo NoFolder
    nAttr = GetAttr(PathName)
    If (nAttr And vbDirectory) = vbDirectory Then
        FolderExists = True
    End If
NoFolder:
    Exit Function
End Function

Private Function CreateFolders(strPath As String)
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
    vPath = Split(strPath, "\")
    strPath = vPath(0) & "\"
    For lngPath = 1 To UBound(vPath)
        strPath = strPath & vPath(lngPath) & "\"
        If Not FolderExists(strPath) Then MkDir strPath
    Next lngPath
lbl_Exit:
    Exit Function
End Function