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:
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:
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:
</replace>
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 SubI'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
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
