match pdf name to recipient list & send to that person

[Royzer]

Hi.

Each week I split a company VISA transaction report into a file for each cardholder with only their activity shown. The filenames have the person's name about midway through. A sample filename would look like this: 010115-0122515 - VISA - Joe Blow, Some Corporation Inc. I would probably need to use a function like =MID to pull the first few letters of the name to match to the list since everything after the second dash is of variable length.

I would like to setup a list of recipient names and their corresponding email addresses. A macro would then loop through the pdf folder, match the file names to the recipient names/email addresses, then have that particular file sent to the person it is matched with (and so on) all the way through the folder.
Is this possible with an Outlook or Excel macro?

[HansV]

Welcome to Eileen's Lounge!

You could compile the list in an Excel worksheet, and run the code from there, using Automation to control Outlook. This is probably the easiest setup to maintain.

Alternatively, you could add all recipients to a folder with contacts in Outlook, and run everything from Outlook. This has the advantage that everything is contained within a single application, but it'd be harder to maintain and to program.

By the way, is the name sufficient to identify the persons uniquely? If there are two persons named Mary Jones, you'd have a problem...

[Royzer]

Thanks, HansV!

re: duplicate names -- you are correct. I hadn't thought of that. I do have some control over the naming of the files when they split. Perhaps I could include the last four digits of their card number. Thank you for bringing that up.


Of the two options you mentioned, my preference would be Excel. I have a good deal of experience with macros (and tweaking other peoples code into what I need). Do you have any idea where I could find some code to get me started? Earlier today I Googled it as many different ways as I could think of but never found anyone who wanted to loop and match files to specific email recipients.

[HansV]

Here is some sample code. You'll have to modify it, of course.
The code uses so-called late binding, so you don't have to set a reference to the Microsoft Outlook object library (which could cause problems if users have different versions of Outlook).

Code: Select all

Sub SendMessages()
    ' Path of folder with PDF files; must end in \
    Const strFolder = "C:\VisaTransactions\"
    Dim objOutlook As Object
    Dim blnStart As Long
    Dim objMessage As Object
    Dim strFile As String
    Dim strName As String
    Dim lngPos As Long
    Dim rngCell As Range
    Dim strEmail As String

    ' Try to get running instance of Outlook
    On Error Resume Next
    Set objOutlook = GetObject(Class:="Outlook.Application")
    If objOutlook Is Nothing Then
        ' Outlook wasn't running so start it
        Set objOutlook = CreateObject(Class:="Outlook.Application")
        If objOutlook Is Nothing Then
            ' We failed
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        blnStart = True
    End If
    On Error GoTo ErrHandler

    ' Get the first filename
    strFile = Dir(strFolder & "*.pdf")
    ' Loop through the files
    Do While strFile <> ""
        ' Find the position of the comma
        lngPos = InStrRev(strFile, ",")
        ' Remove everything starting at the comma
        strName = Left(strFile, lngPos - 1)
        ' Find the position of the last hyphen
        lngPos = InStrRev(strName, "-")
        ' Remove everything up to and including the hyphen
        strName = Mid(strName, lngPos + 1)
        ' Trim the name
        strName = Trim(strName)
        ' Try to find the name
        Set rngCell = Range("A:A").Find(What:=strName, LookAt:=xlWhole, MatchCase:=False)
        ' Did we find the name?
        If Not rngCell Is Nothing Then
            ' Get the email address
            strEmail = rngCell.Offset(0, 1).Value
            ' Create email
            Set objMessage = objOutlook.CreateItem(0) ' 0 = olMailItem
            ' Subject
            objMessage.Subject = "Visa transaction report"
            ' Body
            objMessage.Body = "Your VISA tansactions report is attached to this message" & vbCrLf & _
                "Yours sincerely, Royzer"
            ' Recipient
            objMessage.Recipients.Add strEmail
            ' Attachment
            objMessage.Attachments.Add strFolder & strFile
        End If
        ' Get the next filename
        strFile = Dir
    Loop

ExitHandler:
    On Error Resume Next
    ' Quit Outlook if we started it for this macro
    If blnStart Then
        objOutlook.Quit
    End If
    Exit Sub

ErrHandler:
    ' Display error message
    MsgBox Err.Description, vbExclamation
    ' Then go to the normal exit
    Resume ExitHandler
End Sub

I have added lots of comments in the code to explain what it's doing.

[Royzer]

Thank you, Hans!

[HansV]

I see that I forgot an essential part: actually sending the messages

Code: Select all

            ...
            objMessage.Recipients.Add strEmail
            ' Attachment
            objMessage.Attachments.Add strFolder & strFile
            ' Send the message
            objMessage.Send
        End If
        ...

[Royzer]

I added the code you gave me to Send, but so far nothing is happening when I run the code. I've tried stepping through it as well, and nothing is happening whether Outlook is open or closed when it runs.

I think one problem may be that I have had trouble determining what the final (trimmed) version of the file name is so I can set it up in my Excel list, so I'm not getting a match.

Would you please take a look at the attached file? It was set up to test by sending the files to me and I've included a copy of the folder path from my PC to verify that I've pointed the code to the right location.

[HansV]

My idea was that you'd put the names such as Jimbo Carrier and Normal Brian in column A of the worksheet, and let the code extract the name from the PDF filenames and match that to column A.

[Royzer]

It works great!

The ONLY thing I need to adjust is that the single email for each file is sent with two copies of the same file and also the recipient is showing twice. I've attached pic of what I mean.

[HansV]

You accidentally copied all of the code from my amendment, so that you now have the lines

Code: Select all

            objMessage.Recipients.Add strEmail
            ' Attachment
            objMessage.Attachments.Add strFolder & strFile

twice. Remove one copy of those lines.

(I included those lines to give you an idea where the new lines should be inserted)

[Royzer]

Perfect!

You've helped me so much, Hans, that I hate to ask this question (but I just remembered this): I have the recipient email address in column B. Is there any way to put two more people on the same email by putting their addresses in the adjacent cells in Col C & D?

I PROMISE this is the last question I'll have today! :-)

[HansV]

No problem!

Below the line

Code: Select all

            objMessage.Recipients.Add strEmail

add the following lines:

Code: Select all

            objMessage.Recipients.Add rngCell.Offset(0, 2).Value
            objMessage.Recipients.Add rngCell.Offset(0, 3).Value

[Royzer]

You have given me exactly what I need, Hans. I can't thank you enough!

[HansV]

You're welcome!

Feel free to come back if you have more questions.

[Royzer]

It's finally time to launch this project and I've run into an issue. My expectation was to have 3 email recipients per report but I have received an email list with five recipients and several with four. I know how to expand the email address column range to send to multiple adjacent email addresses. The problem now is that I will need to send a reports to a variable number of email addresses. I tried this once before and the process just stopped when it hit a blank cell. Is there a way for it to move to the next row when it encounters a blank cell?

Thanks!

[HansV]

Try this version:

Code: Select all

Sub SendMessages()
    ' Path of folder with PDF files; must end in \
    Const strFolder = "C:\VisaTransactions\"
    Dim objOutlook As Object
    Dim blnStart As Long
    Dim objMessage As Object
    Dim strFile As String
    Dim strName As String
    Dim lngPos As Long
    Dim rngCell As Range
    Dim c As Long

    ' Try to get running instance of Outlook
    On Error Resume Next
    Set objOutlook = GetObject(Class:="Outlook.Application")
    If objOutlook Is Nothing Then
        ' Outlook wasn't running so start it
        Set objOutlook = CreateObject(Class:="Outlook.Application")
        If objOutlook Is Nothing Then
            ' We failed
            MsgBox "Cannot start Outlook!", vbExclamation
            Exit Sub
        End If
        blnStart = True
    End If
    On Error GoTo ErrHandler

    ' Get the first filename
    strFile = Dir(strFolder & "*.pdf")
    ' Loop through the files
    Do While strFile <> ""
        ' Find the position of the comma
        lngPos = InStrRev(strFile, ",")
        ' Remove everything starting at the comma
        strName = Left(strFile, lngPos - 1)
        ' Find the position of the last hyphen
        lngPos = InStrRev(strName, "-")
        ' Remove everything up to and including the hyphen
        strName = Mid(strName, lngPos + 1)
        ' Trim the name
        strName = Trim(strName)
        ' Try to find the name
        Set rngCell = Range("A:A").Find(What:=strName, LookAt:=xlWhole, MatchCase:=False)
        ' Did we find the name?
        If Not rngCell Is Nothing Then
            ' Create email
            Set objMessage = objOutlook.CreateItem(0) ' 0 = olMailItem
            ' Subject
            objMessage.Subject = "Visa transaction report"
            ' Body
            objMessage.Body = "Your VISA tansactions report is attached to this message" & vbCrLf & _
                "Yours sincerely, Royzer"
            ' Recipients
            c = 1
            Do While rngCell.Offset(0, c).Value <> ""
                objMessage.Recipients.Add rngCell.Offset(0, c).Value
                c = c + 1
            Loop
            ' Attachment
            objMessage.Attachments.Add strFolder & strFile
            ' Send the message
            objMessage.Send
        End If
        ' Get the next filename
        strFile = Dir
    Loop

ExitHandler:
    On Error Resume Next
    ' Quit Outlook if we started it for this macro
    If blnStart Then
        objOutlook.Quit
    End If
    Exit Sub

ErrHandler:
    ' Display error message
    MsgBox Err.Description, vbExclamation
    ' Then go to the normal exit
    Resume ExitHandler
End Sub

You'll have to change the path again of course.

[Royzer]

That did it! You're the best, Hans. Thanks!