VBA Support required (trying to automatically filter PDFs from emails in specific folders.

[terrymac]

I was hoping someone could help me, through google I have found this website.

Here is my problem; I am trying to do some VBA on my Outlook but I know nothing about it.

In my business we have specific documents that are emailed to us in PDF format, which over the coming years get updated. There are thousands of different attachments over thousands of emails, so I tried to use VB to strip the PDFs and then save them.

It all works but the one problem I have is if there is the same file, I need it to check the DATE MODIFIED of the file and overwrite if it is newer.... which would mean I will only be left with the latest of each file..

Here is my command is there a whiz out there who could tell me what to do?


Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
Dim olkFolder As Outlook.MAPIFolder, _
olkAttachment As Outlook.Attachment, _
objFSO As Object, _
strRootFolderPath As String, _
strFilename As String, _
intCount As Integer
'Change the following path to match your environment
strRootFolderPath = "Y:\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set olkFolder = Application.ActiveExplorer.CurrentFolder
If Item.Attachments.count > 0 Then
For Each olkAttachment In Item.Attachments
If objFSO.GetExtensionName(LCase(olkAttachment.FileNa me)) = "pdf" Then
strFilename = olkAttachment.FileName
intCount = 0
Do While True
If objFSO.FileExists(strRootFolderPath & strFilename) Then
intCount = intCount + 1
objFSO.deletefile (strRootFolderPath & strFilename)
Else
Exit Do
End If
Loop
olkAttachment.SaveAsFile strRootFolderPath & strFilename
End If
Next
End If
Set objFSO = Nothing
Set olkAttachment = Nothing
Set olkFolder = Nothing


End Sub

[gmayor]

I am inclined to think that this may not be the ideal approach. I can see why you want the most recent version, but I wonder whether the modified date will reflect the version you want. Such dates are notoriously fickle.

If I was doing it for myself, I would save numbered versions of all the files. That way you have all versions. You can then establish for certain which is the most recent.

It is either that or trust that the date the message was sent makes the file the most recent, in which case, as you are processing the messages as they arrive, you can just overwrite the previous version as they arrive.

There would however be the possibility that different files have the same name, so that takes us back to my original suggestion and to that end I would suggest the following:

Option Explicit

Sub SaveAttachmentsToDisk(Item As Outlook.MailItem)
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
    strRootFolderPath = "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
                strFilename = FileNameUnique(strRootFolderPath, strFilename, "pdf")
                olkAttachment.SaveAsFile strFilename
            End If
        Next
    End If
    Set objFSO = Nothing
    Set olkAttachment = Nothing
End Sub

Private Function FileNameUnique(strPath As String, _
                               strFilename As String, _
                               strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFilename) - (Len(strExtension) + 1)
    strFilename = Left(strFilename, lngName)
    Do While FileExists(strFilename & Chr(46) & strExtension) = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFilename & Chr(46) & strExtension
End Function

Private Function FileExists(ByVal Filename As String) As Boolean
Dim lngAttr As Long
    On Error GoTo NoFile
    lngAttr = GetAttr(Filename)
    If (lngAttr And vbDirectory) <> vbDirectory Then
        FileExists = True
    End If
NoFile:
    Exit Function
End Function

[terrymac]

Thank you Graham, I will do this as a second option.

The only problem is if I create additional files there will be over 10,000 PDFs in total.

I am trying to do a one-off run which sorts all of the PDFs I have from 2007-present.

Going forward the macro I have will automatically update the PDF instantly upon arrival, so I will always have the latest version going forward.

However, for the previous years I am confident the modified date is accurate as these PDFs come from an Adobe Illustrator file and are created on every amendment, so the PDFs modified date is pretty accurate. However, if the command was easier to amend I could go by the date the email was received as that would be guaranteed to be accurate.

So, if anyone could help by updating my command to allow for this scenario I would appreciate it.

[gmayor]

The macro I posted will simply increment the number of the file being downloaded as the messages arrive. If the messages are processed as they arrive then presumably they will carry the latest version and if the filename is the same it should be safe to save the attachment overwriting the existing file, instead of incrementing it.

The existing messages are a bit more of an issue. I'll have to think about that a bit more. However, if they are all in the same Outlook folder then all it should take is to sort the folder by date and time of arrival and process the files in reverse order (or conversely sort them in reverse order and process the files in the sorted order).

Would that work for you?

[terrymac]

Hello Graham,

You are very helpful.

As I will be running this command once only for each folder I have then the simplest way, as you suggested, is to get Outlook to work its way down the list from oldest first, and replacing as it goes. This would ensure I end up with the newest PDFs for each filename.

Then, once I have it all run, all future emails will be instantly uploaded and older PDFs replaced accordingly.

Hopefully I am not being rude in asking if you could edit my original command posted to do this so I could paste it back into the editor?

Regards,
Terry.

[gmayor]

I haven't got time today, but I'll modify it for you tomorrow, if no-one else picks it up overnight.

[gmayor]

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

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

[terrymac]

Graham,

Thank you so much for your help on this I have now managed to get all of my email attachments downloaded and with only the latest version of each type.

So you know the numbers; I started with all emails from 2007, which in the end I had 24,826.

Within these emails there were 89,514 attachments in total.

Because of your help I can now delete all of the archived emails and I am left with 4,503 as of this morning!

[gmayor]

Great stuff. Please mark the thread as Solved.