jgarciaf106
New Member
- Joined
- Mar 16, 2017
- Messages
- 3
Need help to update the code below, so I can send emails on behalf of, instead from my account. I do use ms Exchange.
I am new and currently learning macros all help is appreciated.
I am new and currently learning macros all help is appreciated.
HTML:
#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
#Else
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
#End If
Sub SendAwaitingActions()
'update by Extendoffice 20160506
Dim xEmail As String
Dim xSubj As String
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
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Awaiting Actions Tool by ag732312", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 11 Then
MsgBox " Regional format error, please check", , "Awaiting Actions Tool by ag732312"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 11)
' Message subject
xSubj = "Workday Awaiting Actions " & xRg.Cells(i, 10) & "." & vbCrLf & vbCrLf
' Compose the message
xMsg = ""
xMsg = xMsg & "Dear " & xRg.Cells(i, 10) & "," & vbCrLf & vbCrLf
xMsg = xMsg & "Hope you are well, I would appreciate if you can help us approving the following process on Workday, if needed let me know to rescind the process." & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Awaiting Person: " & xRg.Cells(i, 10).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Employee ID: " & xRg.Cells(i, 1).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Worker: " & xRg.Cells(i, 2).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Country: " & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Business Process: " & xRg.Cells(i, 4).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Business Process Transaction: " & xRg.Cells(i, 5).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Date and Time Initiated: " & xRg.Cells(i, 6).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Status: " & xRg.Cells(i, 7).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Reason: " & xRg.Cells(i, 8).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Business Process Step or To Do Awaiting Action (Includes Subprocesses): " & xRg.Cells(i, 9).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "Do not hesitate in contacting us if you need additional support. " & vbCrLf
xMsg = xMsg & "test Latam: test@test.com"
' 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 & "?subject=" & xSubj & "&body=" & xMsg
' 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