Excel Mail Merge | Attachment and Signature Issues

coryjacques

New Member
Joined
May 17, 2019
Messages
14
Hello,
I found the below code on a KutTools guide and modified it a bit to suit my needs:
Code:
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As Long, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
Sub Email_Blast()
'update by Extendoffice 20160506
    Dim xEmail As String
    Dim myCC As String
    Dim xSubj As String
    Dim mySubject As Variant
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    Dim myAtt As Variant
    
    
mySubject = InputBox("Select the subject for your message", "Subject")
myAtt = InputBox("Add the full file path to your file location.", "Attachments")
    
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the data range. Hit Cancel to end macro.", _
"Data", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    For i = 1 To xRg.Rows.Count
'       Get the email address
        xEmail = xRg.Cells(i, 2)
        myCC = xRg.Cells(i, 3)
'       Message subject
        xSubj = mySubject
'       Compose the message
        xMsg = ""
        xMsg = xMsg & xRg.Cells(i, 4).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 5).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 6).Text & vbCrLf & vbCrLf
'       Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
        xURL = "mailto:" & xEmail & "?cc=" & myCC & "&subject=" & xSubj & "&body=" & xMsg & _
"&attachment=" & myAtt
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next
End Sub
I'm having a hard time getting myATT to load as an attachment. It seems like the myATT section of this line is not being read, whereas everything else is working as expected:
Code:
xURL = "mailto:" & xEmail & "?cc=" & myCC & "&subject=" & xSubj & "&body=" & xMsg & _
"&attachment=" & myAtt
Also, I have a similar macro set up to do a BCC email blast (though frankly it's irrelevant because its faster to just copy a range from excel and paste it into BCC... really overthought that one...) where I was able to insert a signature, but I can't seem to get it to work in this Sub. Any assistance? Original code below:
Code:
Sub ContactList()
   Dim olApp As Object
   Dim olMailItm As Object
   Dim iCounter As Integer
   Dim Dest As Variant
   Dim SDest As String
   Dim CC As String
   Dim myValue As Variant
   Dim myCC As Variant
   Dim myAttachment As Variant
   Dim SigString As String
   Dim Signature As String
   Dim Path As Variant
   Dim Check As Variant
      
'Set up fields'
   
   myValue = InputBox("Set Subject Line - Press cancel to end macro", "Subject must be included")
    If myValue = "" Then Exit Sub
    
    
   myCC = InputBox("Set CC Line", "CC")
    If myCC = vbCancel Then Exit Sub
   Path = InputBox("Add the path to any attachments you wish to add. Select Cancel to send without attachments", "Attachments")
   Check = MsgBox("Send Email?", vbYesNo, "Final Check")
        If Check = vbNo Then Exit Sub
   
   Set olApp = CreateObject("Outlook.Application")
   Set olMailItm = olApp.CreateItem(0)
   SigString = Environ("appdata") & _
            "\Microsoft\Signatures\Gen.htm" '<replace name="" your="" of="" the="" with="" gen="" signature'
    
   If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
   On Error Resume Next
'Send Message'
   With olMailItm
       SDest = ""
       For iCounter = 1 To WorksheetFunction.CountA(Columns(1))
           If SDest = "" Then
               SDest = Cells(iCounter, 1).Value
           Else
               SDest = SDest & ";" & Cells(iCounter, 1).Value
           End If
       Next iCounter
       
       .BCC = SDest
       .CC = myCC
       .Subject = myValue
       .Body = ActiveSheet.TextBoxes(1).Text & Signature
       .display
       .attachments.Add Path
       .HTMLBody = ActiveSheet.TextBoxes(1).Text & Signature
       .send
   End With
   Set olMailItm = Nothing
   Set olApp = Nothing
Result = MsgBox("Emails Sent", vbOKOnly, "Complete")
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.getfile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
</replace>
 

coryjacques

New Member
Joined
May 17, 2019
Messages
14
I tried setting this up as the following but nothing has changed:
Code:
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As Long, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
Sub Email_Blast()
    Dim xEmail As String
    Dim myCC As String
    Dim xSubj As String
    Dim mySubject As Variant
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    Dim myAtt As Variant
    Dim Sig As String
    Dim sigstring As String
    
    
mySubject = InputBox("Select the subject for your message", "Subject")
myAtt = InputBox("Add the full file path to your file location.", "Attachments")
    
   Set olApp = CreateObject("Outlook.Application")
   Set olMailItm = olApp.CreateItem(0)
   sigstring = Environ("appdata") & _
            "\Microsoft\Signatures\Cory.htm" '<Replace Cory with the name of your signature'
    
   If Dir(sigstring) <> "" Then
        Signature = GetBoiler(sigstring)
    Else
        Signature = ""
    End If
   On Error Resume Next
   
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the data range. Hit Cancel to end macro.", _
"Data", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    For i = 1 To xRg.Rows.Count
'       Get the email address
        xEmail = xRg.Cells(i, 2)
        myCC = xRg.Cells(i, 3)
'       Message subject
        xSubj = mySubject
'       Compose the message
        xMsg = ""
        xMsg = xMsg & xRg.Cells(i, 4).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 5).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 6).Text & vbCrLf & vbCrLf
'       Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
        xURL = "mailto:" & xEmail & "?cc=" & myCC & "&subject=" & xSubj & "&body=" & xMsg & Sig & _
"&attachment=" & myAtt
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.getfile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

/CODE]
 

coryjacques

New Member
Joined
May 17, 2019
Messages
14
sorry -

Code:
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As LongPtr, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As Long, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
Sub Email_Blast()
    Dim xEmail As String
    Dim myCC As String
    Dim xSubj As String
    Dim mySubject As Variant
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    Dim myAtt As Variant
    Dim Sig As String
    Dim sigstring As String
    
    
mySubject = InputBox("Select the subject for your message", "Subject")
myAtt = InputBox("Add the full file path to your file location.", "Attachments")
    
   Set olApp = CreateObject("Outlook.Application")
   Set olMailItm = olApp.CreateItem(0)
   sigstring = Environ("appdata") & _
            "\Microsoft\Signatures\Cory.htm" '<Replace Cory with the name of your signature'
    
   If Dir(sigstring) <> "" Then
        Signature = GetBoiler(sigstring)
    Else
        Signature = ""
    End If
   On Error Resume Next
   
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the data range. Hit Cancel to end macro.", _
"Data", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    For i = 1 To xRg.Rows.Count
'       Get the email address
        xEmail = xRg.Cells(i, 2)
        myCC = xRg.Cells(i, 3)
'       Message subject
        xSubj = mySubject
'       Compose the message
        xMsg = ""
        xMsg = xMsg & xRg.Cells(i, 4).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 5).Text & vbCrLf & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 6).Text & vbCrLf & vbCrLf
'       Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
        xURL = "mailto:" & xEmail & "?cc=" & myCC & "&subject=" & xSubj & "&body=" & xMsg & Sig & _
"&attachment=" & myAtt
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.getfile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
 

Forum statistics

Threads
1,077,687
Messages
5,335,662
Members
399,032
Latest member
thefinu

Some videos you may like

This Week's Hot Topics

Top