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

gmayor · 11-15-2014, 02:07 AM

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:

Code:

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