I am using the following script to send emails from excel (MS Office 2003).
I need to adjust the From line in Outlook to be from a house account ( I have permissions). So instead of From: Joe Smith it would be From: Building Maintenance.
Here is the script I am using now.
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 = 2 To 4 'data in rows 2-4
' Get the email address
Email = Cells(r, 10)
' Message subject
Subj = "General Services Customer Satisfaction"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 10) & "," & vbCrLf & vbCrLf
Msg = Msg & "We recently completed work for you described as "
Msg = Msg & Cells(r, 12).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "That was completed on " & Cells(r, 6) & vbCrLf & vbCrLf
Msg = Msg & "Please click on this link to tell us how we did" & vbCrLf
Msg = Msg & "
' 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 = "mailfrom:" & 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
Advice?
I need to adjust the From line in Outlook to be from a house account ( I have permissions). So instead of From: Joe Smith it would be From: Building Maintenance.
Here is the script I am using now.
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 = 2 To 4 'data in rows 2-4
' Get the email address
Email = Cells(r, 10)
' Message subject
Subj = "General Services Customer Satisfaction"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 10) & "," & vbCrLf & vbCrLf
Msg = Msg & "We recently completed work for you described as "
Msg = Msg & Cells(r, 12).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "That was completed on " & Cells(r, 6) & vbCrLf & vbCrLf
Msg = Msg & "Please click on this link to tell us how we did" & vbCrLf
Msg = Msg & "
' 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 = "mailfrom:" & 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
Advice?