Consulting

Results 1 to 6 of 6

Thread: Send multiple different pdf to contacts on list

  1. #1

    Send multiple different pdf to contacts on list

    Hi! Im new here and really looking forward to learn about vba , in the meantime, I wanted to ask your kind help in order to sort this out.
    I receive several different pdf files on outlook, the subject will always be the invoice number, then customers name.

    I have an excel list , and what I want to achieve is basically run a macro so that way it will search for a file within a folder (files are named after the emails subject) then attach it and send it to the contact person on the list.


    So far I have the following code:



    Sub macro()

    Dim olApp As Outlook.Application
    Dim olMail As Outlook.MailItem
    Dim fso
    Dim file As String


    For I = 2 To Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Set olApp = New Outlook.Application
    Set olMail = olApp.CreateItem(olMailItem)

    With olMail
    .To = Cells(I, 1).Value
    .subject = Cells(I, 2).Value
    .body = Cells(I, 3).Value
    .Attachments.Add Range("D2").Value & "\" & Range("E2").Value & ".pdf"
    .Send

    End With

    Next

    End Sub

    But the thing s all I have been able to achieve is to send emails with the same file attached (in this case the file on E2)
    Anything you guys can suggest ? running out of options
    Attached Images Attached Images

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Welcome to the forum! I am unclear on some things. Are you wanting to send one email per unique Recipent with all files in Path and filename in Subject? Or?

  3. #3
    Thats correct , every line is a customer , every line contains one single file to be sent.

  4. #4
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    Yes but your thread says send multiple files. From what you posted, I gleamed that you meant for a macro to get unique emails, do a multiple find or filter for each unique one, and then build the file list accordingly.

    One of the best ways to get help is to include a small sample obfuscated file. You can do so by clicking the bottom right of a reply Go Advanced button, and then the paperclip icon, and then Browse and Upload. If what I surmised is correct, even that won't be needed though your Subject and Body fields do not match the fields/column headings in your picture. Of course that means that Subject and Body would have to come from the first row found.

    At some point, the macro may need to see if each file in the unique email rows exist. That can be handled later if needed.

  5. #5

    Sample file

    Keneth
    Hope this one helps, thanks in advance for your help.
    Attached Files Attached Files

  6. #6
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,956
    Location
    I used the Filter method and dded another column:
    To, Subject, Body, Path, PDFname

    Sub Main()  
      Dim olApp As Outlook.Application, olMail As Outlook.MailItem
      Dim fso, file As String, i As Long, j As Long
      Dim a() As Variant, r As Range, rr1 As Range, rr2 As Range
      Dim aRR1() As Variant, aRR2() As Variant, sAdd As String
      
      Set olApp = New Outlook.Application
      
      a() = Range("A2", Range("A" & Rows.Count).End(xlUp))
      a() = UniqueArrayByDict(a(), compareMethod.TextCompare) 'Unique but ignore case.
      'MsgBox Join(a, vbLf)
    
    
      For i = LBound(a) To UBound(a)
        Range("A1").CurrentRegion.AutoFilter 1, Criteria1:=a(i), Operator:=xlAnd
        Set r = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
        Set r = StripFirstRow(r)
        If r Is Nothing Then GoTo NextI
        
        Set rr1 = r.Columns(4)  'Attachment file paths
        Set rr2 = rr1.Offset(, 1) 'Attachment file basenames
        On Error GoTo OneMatch
        aRR1() = WorksheetFunction.Transpose(rr1) 'Attachment file paths
        aRR2() = WorksheetFunction.Transpose(rr2) 'Attachment file basenames
        For j = LBound(aRR1) To UBound(aRR1)
          aRR1(j) = aRR1(j) & "\" & aRR2(j) & ".pdf"
        Next j
    OneMatch:
        If Err.Number = 13 Then
          sAdd = rr1.Value & "\" & rr2.Value & ".pdf"
          On Error GoTo 0
        End If
      
        On Error GoTo 0
        Set olMail = olApp.CreateItem(olMailItem)
        With olMail
          .To = rr1.Cells(1).Offset(, -3).Value       'Column A
          .Subject = rr1.Cells(1).Offset(, -2).Value  'Column B
          .body = rr1.Cells(1).Offset(, -1).Value     'Column C
          On Error Resume Next 'Skip if file does not exist.
          If rr1.Cells.Count = 1 Then
              .Attachments.Add sAdd
            Else
            For j = LBound(aRR1) To UBound(aRR1)
              .Attachments.Add aRR1(j)
            Next j
          End If
          '.Display
          .Send
        End With
    NextI:
      Next i
      
    EndNow:
      ActiveSheet.UsedRange.CurrentRegion.AutoFilter
      Set olMail = Nothing
      Set olApp = Nothing
    End Sub
    
    
    'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
    Function UniqueArrayByDict(Array1d() As Variant, Optional compareMethod As Integer = 0) As Variant
      Dim dic As Object 'Late Binding method - Requires no Reference
      Set dic = CreateObject("Scripting.Dictionary")  'Late or Early Binding method
      'Dim dic As Dictionary     'Early Binding method
      'Set dic = New Dictionary  'Early Binding Method
      Dim e As Variant
      dic.CompareMode = compareMethod
      'BinaryCompare=0
      'TextCompare=1
      'DatabaseCompare=2
      For Each e In Array1d
        If Not dic.Exists(e) Then dic.Add e, Nothing
      Next e
      UniqueArrayByDict = dic.Keys
    End Function
    
    
    Function StripFirstRow(aRange As Range) As Range
      Dim i As Long, j As Long, r As Range, z As Long, idx As Long
      For i = 1 To aRange.Areas.Count
        For j = 1 To aRange.Areas(i).Rows.Count
          z = z + 1
          If z = 1 Then GoTo NextJ
          If r Is Nothing Then
            Set r = aRange.Areas(i).Rows(j)
            Else
            Set r = Union(r, aRange.Areas(i).Rows(j))
          End If
    NextJ:
        Next j
      Next i
      Set StripFirstRow = r
    End Function
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •