Need help adapting existing Excel email code (that works)

[Royzer]

HansV gave me this code a couple of years ago to match pdf file names with a list in Excel and email each file to email addresses specified on the same row. The file name example I used then was:

010115-0122515 - VISA - Joe Blow, Some Corporation Inc


I am trying to adapt the code send Excel files. The problem is that the existing code looks for things in the file names that the Excel files will not have, such as "," and "-". I've tinkered with it for quite some time and just can't figure out what needs to be changed to send files with names in this format: "BLUE TELEVISION KLAB.xlsx". The last four characters will be the only difference between file names in the folder.

I'd appreciate any help you can give me.

Thanks!

Code: Select all

Sub SendMessages()

    ' This is the folder where the Excel files will be located
    Const strFolder = "U:\02-T-CHEK\T-Chek Split Files\"
    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 (changed extension to .xlsx)
    strFile = Dir(strFolder & "*.xlsx")
    ' 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 = "T-Chek Card Status report"
            ' Body
            objMessage.Body = "Please review the attached T-Chek Card Status report." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
                "NAME" & vbCrLf & _
                "TITLE" & vbCrLf & _
                "ADDRESS1" & vbCrLf & _
                "ADDRESS2" & vbCrLf & _
                "PHONE (office)" & vbCrLf & _
                "PHONE (cell)"
            
            ' 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

[HansV]

I don't have access to a PC at the moment. If nobody else replies, I will look at it on Wednesday.

[Rudi]

Give this a try...

Note:
I have changed the code to "Display" the message instead of "Sending" the message.
If the code is functioning fine, you can switch back to Sending it immediately.

To do so, change this line...

Code: Select all

objMessage.Display '.Send

...to look like this:

Code: Select all

objMessage.Send

Full code to test:

Code: Select all

Sub SendMessages()

    ' This is the folder where the Excel files will be located
    Const strFolder = "U:\02-T-CHEK\T-Chek Split Files\"
    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 (changed extension to .xlsx)
    strFile = Dir(strFolder & "*.xlsx")
    ' Loop through the files
    Do While strFile <> ""
        ' Extract Filename without extention and Trim
        strName = Trim(Split(strFile, ".")(0))
        ' 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 = "T-Chek Card Status report"
            ' Body
            objMessage.Body = "Please review the attached T-Chek Card Status report." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
                "NAME" & vbCrLf & _
                "TITLE" & vbCrLf & _
                "ADDRESS1" & vbCrLf & _
                "ADDRESS2" & vbCrLf & _
                "PHONE (office)" & vbCrLf & _
                "PHONE (cell)"
            
            ' 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.Display '.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

BTW: I moved this thread to the Excel forum as it is VBA code that runs in Excel, not Outlook.

[Royzer]

That is exactly what I needed. Thanks Rudi!