Handy VBS script for mass attachment export from outlook to a folder

This is a script I use every now and then for renumeration of attachments. It was working fine even in Outlook 2007. Note that if the attachment name is the same (and typically it is if you scan a document, then it handles these gently and renames the files incrementally).

Open up your Outlook:

1. Be sure you put all the files into a folder in Outlook and you selected the folder (below, it is the class folder that has the pdfs).
2. Be sure you pressed Alt F11.

Then you can run the following VBS script which will put all the files to this path,c:\exploded\

Sub ExtractAllPDF()
    'On the next line, edit the path to the folder you want to save the extracted PDFs in.  The path must end with a \
    Const SAVE_TO_FOLDER = "c:\exploded\"
    Const MACRO_NAME = "Extract All PDF Files"
    Dim olkFld As Outlook.Folder, olkMsg As Object, olkAtt As Outlook.Attachment, lngCnt As Long
    lngCnt = 1
    Set olkFld = Application.ActiveExplorer.CurrentFolder
    For Each olkMsg In olkFld.Items
        For Each olkAtt In olkMsg.Attachments
            If Right(LCase(olkAtt.FileName), 4) = ".pdf" Then
                olkAtt.SaveAsFile SAVE_TO_FOLDER & lngCnt & ".pdf"
                lngCnt = lngCnt + 1
            End If
        Next
    Next
    MsgBox "PDF extraction complete.", vbInformation + vbOKOnly, MACRO_NAME
End Sub