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
Dim Msg As String, URL As String
Dim r As Integer, x As Double
For r = 1 To 100 'data in rows 1 - 100
' Get the email address
Email = Cells(r, 2)
' Message subject
Subj = "Rev1 Power Services"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf
Msg = Msg & "I am with (My Company). We Specialize in hard to find, highly qualified contract personnel, such as turbine technical advisors, controls engineers, project managers, schedulers, etc., as well as the more common disciplines. We also maintain a large pool of navy nuclear trained entry level personnel." & vbCrLf & vbCrLf
Msg = Msg & "(My Company) operates with a minimal overhead, so we can provied someo of the most competitive rates in the industry, while maintaining a tight focus on quality of service on all projects served." & vbCrLf & vbCrLf
Msg = Msg & "Current clients include American Electric Power, Dominion Power, Florida Power and Light, Consolidated Edison, Silicon Valley Power, Worley Parsons, URS Group, Washington Gropu Iinternational, Shaw Group, Tampa Electric Company, Santee Cooper, CH2M Hill, and many others." & vbCrLf & vbCrLf
Msg = Msg & "Additional information can be found via our website at (company website) and in the brochure I have attached to this email. I look forward to hearing back from you and hopefully my company can be of service to you in the timely and successful completion of your current and upcoming projects." & vbCrLf & vbCrLf & vbCrLf
Msg = Msg & "Sincerely" & 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 & "?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
Bookmarks