Search code examples
vbapdfoutlookemail-attachments

Save PDF attachments only using If UCase + SaveAsFile + SenderEmailAddress


I have two VBA macros that are slightly different and I want to combine the best of both.

Both save attachments within a selection of emails, however:

Macro A saves every attachment within the selection as a PDF. Some are JPEG signatures or disclaimers etc. that I don't want. The plus side is that it uses eml.SenderEmailAddress which is super as I want the name of the saved attachment to include 'someone@something.com'

Macro B saves every attachment within the selection as a PDF but uses the If UCase function to filter out PDF files only. For instance if an email contains a .txt and .pdf file, only the PDF file is considered. I don't have to clean out fake pdfs.
I cannot figure out how to incorporate SenderEmailAddress into this macro.

How do I merge the features in bold above?

Macro A)

Sub SaveAttachmentsFromSelectedItemsPDF()

    Dim currentItem As Object
    Dim currentAttachment As Attachment
    Dim saveToFolder As String
    Dim savedFileCountPDF As Long

    saveToFolder = "the_path_private_its_a_work_one_lol"

    savedFileCountPDF = 0
    For Each currentItem In Application.ActiveExplorer.Selection
        For Each currentAttachment In currentItem.Attachments
            If UCase(Right(currentAttachment.DisplayName, 4)) = ".PDF" Then
                currentAttachment.SaveAsFile saveToFolder & "\" & _
                    Left(currentAttachment.DisplayName, Len(currentAttachment.DisplayName) - 4) & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & ".pdf"
                savedFileCountPDF = savedFileCountPDF + 1
            End If
        Next currentAttachment
    Next currentItem

    MsgBox "Number of PDF files saved: " & savedFileCountPDF, vbInformation

End Sub

Macro B)

Sub attsave_yann()
Dim win As Outlook.Explorer
Dim sel As Outlook.Selection
Dim att As Outlook.Attachments
Dim eml As MailItem
Dim i As Integer
Dim fn As String
Dim objAtt As Outlook.Attachment

Dim myRandom As Double
Randomize 'Initialize the Rnd function
 
myRandom = Rnd 'Generate a random number between 0-1
 
 
' Count = Count + 1
 
Set win = Application.ActiveExplorer
Set sel = win.Selection
    For Each eml In sel
        Set att = eml.Attachments
        
        
        If UCase(Right(att.DisplayName, 4)) = ".PDF" Then
            For i = 1 To att.Count
                fn = "the_path_private_its_a_work_one_lol" & eml.SenderEmailAddress & "_" & Rnd & "_.pdf"
                att(i).SaveAsFile fn
            Next i
        End If
    Next
End Sub

Solution

  • B is almost there:

    Sub attsave_yann()
        Dim eml As MailItem
        Dim fn As String
        Dim objAtt As Outlook.Attachment
        
        Randomize 'Initialize the Rnd function
        
        For Each eml In Application.ActiveExplorer.Selection
            For Each objAtt In eml.Attachments
                'need to test objAtt.DisplayName
                If UCase(objAtt.DisplayName) Like "*.PDF" Then
                    fn = "the_path_private_its_a_work_one_lol" & _
                         DomainOnly(eml.SenderEmailAddress) & "_" & Rnd & "_.pdf"
                    objAtt.SaveAsFile fn
                End If
            Next objAtt
        Next
    End Sub
    
    'return only the part after the `@`
    Function DomainOnly(sAddr as string)
        Dim arr
        arr = Split(sAddr, "@")
        if UBound(arr) = 0 then
            DomainOnly = sAddr
        Else
            DomainOnly = arr(1)
        End If
    End Function