Microsoft Office Forums - View Single Post - [Solved] VBA Support required (trying to automatically filter PDFs from emails in specific folders.

gmayor · 11-17-2014, 11:45 PM

OK - the following should do the job provided the Outlook folder only contains mail items and as you have multiple Outlook folders to process, the macro creates subfolders in the selected Root folder into which the PDFs from that Outlook folder are saved. I have not corrected for illegal Windows filename characters in the Outlook folder names, or for folders that contain items other than mail items.

There are two similar subs. One is run from a rule, the other from the macro ProcessFolder, which does as its name implies. It prompts for the mail folder to process

Because you have been talking about thousands of files I have added a progress indicator. You will need to download the attachment and import the userform it contains into the Outlook project.

Replace all the earlier code with the following and note the change of Sub names shoud you have already created the rule for the original version.

The ProcessFolder macro should now sort the folder in reverse order and process any PDFs attached to the messages, overwriting any existing PDFs of the same names

Code:

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