BrianExcel
Well-known Member
- Joined
- Apr 21, 2010
- Messages
- 975
Ok folks, here is the question of the day.
I have two formulas that I found online for emailing within VBA for Excel 2007. Both work fine, but I need to combine them into one function IF POSSIBLE.
The first basically identifies an email address in Column A of the first sheet, and then formulates a message based on criteria I've specified within Outlook.
The second actually tries to send a worksheet from within Excel and sends a specific range that I designate as an HTML message. I believe it sends through Outlook but the options for TO: CC:, etc are within Excel.
I basically need code that will identify the email address, insert the TO: CC: etc., as I specify and then put the range from the second function in. In short, I need to add teh second function to the first. Here is the code I am using
FIRST CODE
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
Sub SendEMail()
Dim Email As String, Subj As String, Name As String, cc As String, Space As String
Dim Msg As String, URL As String
Dim Qtr As String, Year As String
Dim r As Integer, x As Double
For r = 3 To 5
'======================================================
' The following commands retrieve information from sheet 1 _
' regarding who & where to send the email. It also includes _
' information on the address and store number for email body.
Email = Sheet1.Cells(r, 1)
Name = Sheet1.Cells(r, 2)
Store# = Sheet1.Cells(r, 3)
Street = Sheet1.Cells(r, 4)
City = Sheet1.Cells(r, 5)
State = Sheet1.Cells(r, 6)
Zip = Sheet1.Cells(r, 7)
Space = " "
cc = "Stephanie.Burdette@fedex.com; Edee.Robinett@fedex.com"
Subj = "FedEx Office " & State & Space & Store# & " - Quarterly Gross Sales Report"
' Message composition
Msg = ""
Msg = Msg & "Dear " & Name & "," & vbCrLf & vbCrLf
Msg = Msg & "Please find below the Gross Sales Report for location "
Msg = Msg & Store#
Msg = Msg & " located at "
Msg = Msg & Street & City & ", " & State & " " & Zip & "." & vbCrLf & vbCrLf
Msg = Msg & Signature & vbCrLf
' Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
' Create the URL
URL = "mailto:" & Email & "&cc=" & cc & "?subject=" & Subj & "&body=" & Msg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
Next r
End Sub
SECOND CODE
Sub Send_Range()
Dim Month As Date
Dim intMonth As String
intMonth = Date
ActiveSheet.Range("A10:H44").Select
' Show the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = True
' Set the optional introduction field thats adds
' some header text to the email body. It also sets
' the To and Subject lines. Finally the message
' is sent.
With ActiveSheet.MailEnvelope
.Introduction = "Please see the below Gross Sales Information processed for store 0115 located in Austin TX."
.Item.To = "Brian.Burdette@fedex.com"
.Item.Subject = "FedEx Office Gross Sales Information for " & intMonth
.Item.Send
End With
End Sub
I would prefer to insert the second function into the first if possible, because I would like to manage the sending of the messages through Outlook. Doing it this way also allows a sort of 'Preview' before the message is sent.
I am desperate!!! ANY help is appreciated!!
I have two formulas that I found online for emailing within VBA for Excel 2007. Both work fine, but I need to combine them into one function IF POSSIBLE.
The first basically identifies an email address in Column A of the first sheet, and then formulates a message based on criteria I've specified within Outlook.
The second actually tries to send a worksheet from within Excel and sends a specific range that I designate as an HTML message. I believe it sends through Outlook but the options for TO: CC:, etc are within Excel.
I basically need code that will identify the email address, insert the TO: CC: etc., as I specify and then put the range from the second function in. In short, I need to add teh second function to the first. Here is the code I am using
FIRST CODE
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
Sub SendEMail()
Dim Email As String, Subj As String, Name As String, cc As String, Space As String
Dim Msg As String, URL As String
Dim Qtr As String, Year As String
Dim r As Integer, x As Double
For r = 3 To 5
'======================================================
' The following commands retrieve information from sheet 1 _
' regarding who & where to send the email. It also includes _
' information on the address and store number for email body.
Email = Sheet1.Cells(r, 1)
Name = Sheet1.Cells(r, 2)
Store# = Sheet1.Cells(r, 3)
Street = Sheet1.Cells(r, 4)
City = Sheet1.Cells(r, 5)
State = Sheet1.Cells(r, 6)
Zip = Sheet1.Cells(r, 7)
Space = " "
cc = "Stephanie.Burdette@fedex.com; Edee.Robinett@fedex.com"
Subj = "FedEx Office " & State & Space & Store# & " - Quarterly Gross Sales Report"
' Message composition
Msg = ""
Msg = Msg & "Dear " & Name & "," & vbCrLf & vbCrLf
Msg = Msg & "Please find below the Gross Sales Report for location "
Msg = Msg & Store#
Msg = Msg & " located at "
Msg = Msg & Street & City & ", " & State & " " & Zip & "." & vbCrLf & vbCrLf
Msg = Msg & Signature & vbCrLf
' Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
' Create the URL
URL = "mailto:" & Email & "&cc=" & cc & "?subject=" & Subj & "&body=" & Msg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"
Next r
End Sub
SECOND CODE
Sub Send_Range()
Dim Month As Date
Dim intMonth As String
intMonth = Date
ActiveSheet.Range("A10:H44").Select
' Show the envelope on the ActiveWorkbook.
ActiveWorkbook.EnvelopeVisible = True
' Set the optional introduction field thats adds
' some header text to the email body. It also sets
' the To and Subject lines. Finally the message
' is sent.
With ActiveSheet.MailEnvelope
.Introduction = "Please see the below Gross Sales Information processed for store 0115 located in Austin TX."
.Item.To = "Brian.Burdette@fedex.com"
.Item.Subject = "FedEx Office Gross Sales Information for " & intMonth
.Item.Send
End With
End Sub
I would prefer to insert the second function into the first if possible, because I would like to manage the sending of the messages through Outlook. Doing it this way also allows a sort of 'Preview' before the message is sent.
I am desperate!!! ANY help is appreciated!!