CODEWITHSUNDEEP
vbapdfoutlook
J. Doez
J. Doez

Reputation: 13

Save only PDF attachments VBA Outlook

This is what I have so far:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "P:\ME\TEST\"
Dim dateFormat
dateFormat = Format(Now, "yyyy.mm.dd")
 For Each objAtt In itm.Attachments
    If InStr(1, objAtt.FileName, "HALJD", vbTextCompare) > 0 Then
    objAtt.SaveAsFile saveFolder & dateFormat & " ASDF ADFA.pdf"
    ElseIf InStr(1, objAtt.FileName, "Generic", vbTextCompare) > 0 Then
    objAtt.SaveAsFile saveFolder & dateFormat & " asdf asdf asdf.pdf"
    ElseIf InStr(1, objAtt.FileName, "asdfa asdfsa", vbTextCompare) > 0 Then
    objAtt.SaveAsFile saveFolder & dateFormat & " asdfds adsfa asdf a.pdf"
    ElseIf InStr(1, objAtt.FileName, "asdfs_asdfs", vbTextCompare) Then
    objAtt.SaveAsFile saveFolder & dateFormat & " asfd asfda sadfsad.pdf"
    Else
  End If
 Set objAtt = Nothing
Next
End Sub

I get emails with two files named the exact same thing except one is excel and one is pdf. I just need the PDF but am unsure of how to code this. Just need to throw in a line after the last elseif statement right? Let me know what you come up with.

Thanks for help!

Upvotes: 0

Views: 2472

Answers (2)

Parfait
Parfait

Reputation: 107567

Consider directly checking the extension in file name with RIGHT(..., 3). And for readibility and maintainability, consider re-wording the macro using LIKE and defining a string variable conditionally then build file path in SaveAs. Finally, try using one line If statements simply:

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)

  Dim objAtt As Outlook.Attachment
  Dim saveFolder As String: saveFolder = "P:\ME\TEST\"
  Dim dateFormat: dateFormat = Format(Now, "yyyy.mm.dd")
  Dim strFile As String

  For Each objAtt In itm.Attachments

     If Right(objAtt.FileName, 3) = "pdf" Then
         If objAtt.FileName Like "*HALJD*" Then strFile = " ASDF ADFA.pdf"
         If objAtt.FileName Like "*Generic*" Then strFile = " asdf asdf asdf.pdf"
         If objAtt.FileName Like "*asdfa asdfsa*" Then strFile = " asdfds adsfa asdf a.pdf"
         If objAtt.FileName Like "*asdfs_asdfs*" Then strFile = " asfd asfda sadfsad.pdf"

         objAtt.SaveAsFile saveFolder & dateFormat & strFile
     End If          

  Next objAtt

  Set objAtt = Nothing
End Sub

Upvotes: 0

Darren Bartrup-Cook
Darren Bartrup-Cook

Reputation: 19737

I haven't fully tested this as it's a bit of a combination of your code and mine.

The main bits to look at are
Set objFSO = CreateObject("Scripting.FileSystemObject") and
sExt = objFSO.GetExtensionName(objAtt.FileName)

Sub saveAttachtoDisk(ByVal item As MailItem)

    Dim objAtt As Attachment
    Dim i As Integer
    Dim dateFormat As String
    Dim objFSO As Object
    Dim sExt As String

    dateFormat = Format(Date, "yyyy.mm.dd")

    'Only proceed if the email contains attachements.
    If item.Attachments.Count > 0 Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")

        'Cycle through each attachment on the email.
        For i = 1 To item.Attachments.Count
            Set objAtt = item.Attachments(i)

            'Get the extension of the attached file name.
            sExt = objFSO.GetExtensionName(objAtt.FileName)

            If sExt = "pdf" Then
                If InStr(1, objAtt.FileName, "HALJD", vbTextCompare) > 0 Then
                    objAtt.SaveAsFile saveFolder & dateFormat & " ASDF ADFA.pdf"
                ElseIf InStr(1, objAtt.FileName, "Generic", vbTextCompare) > 0 Then
                    objAtt.SaveAsFile saveFolder & dateFormat & " asdf asdf asdf.pdf"
                ElseIf InStr(1, objAtt.FileName, "asdfa asdfsa", vbTextCompare) > 0 Then
                    objAtt.SaveAsFile saveFolder & dateFormat & " asdfds adsfa asdf a.pdf"
                ElseIf InStr(1, objAtt.FileName, "asdfs_asdfs", vbTextCompare) Then
                    objAtt.SaveAsFile saveFolder & dateFormat & " asfd asfda sadfsad.pdf"
                End If
            End If

            'Any remaining events are completed before the code continues.
            DoEvents
            Set objAtt = Nothing
        Next i
        Set objFSO = Nothing
    End If
End Sub

Upvotes: 1

Related Questions