Save PDF attachments only using If UCase + SaveAsFile + SenderEmailAddress

Question

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

Tim Williams · Accepted Answer · 2021-07-12T15:35:13.647

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

I just had a 2nd thought just now: is it possible to SaveFileAs using only the domain name? So for instance, in my world (finance), when I'd run you're improved code, it would be great to get it saved down as '@UBS.com' or 'UBS.com' or 'goldmansachs.com' - any ideas? — Yann, Jul 12 '21 at 11:42

Save PDF attachments only using If UCase + SaveAsFile + SenderEmailAddress

1 Answers1