juan villa
New Member
Code:
Sub SendEMail()
Dim r As Integer, x As Double
Dim quote As String
quote = Chr(34)
For r = 2 To 4 'data in rows 2-4
' Get the email address
Email = Cells(r, 3)
' Message subject
Subj = "PC refresh notification :Asset:" & Cells(r, 4)
' Compose the message
Msg = "Dear " & Cells(r, 2) & "," & vbCrLf & vbCrLf
Msg = Msg & "The asset listed in the subject line above is assigned to you and is due for refresh. Please provide me via" & vbCrLf
Msg = Msg & "reply to this email your model preference. Model options are:" & vbCrLf & vbCrLf
Msg = Msg & "Standard laptop (standard model for all users)" & vbCrLf
Msg = Msg & "Standard desktop (production / tire building floor PCs)" & vbCrLf
Msg = Msg & "Engineering laptop (for qualifying users - see below)" & vbCrLf
Msg = Msg & "SEngineering desktop (for qualifying users only)" & vbCrLf & vbCrLf
Msg = Msg & "For engineering models:" & vbCrLf
Msg = Msg & "In order to proceed with " & quote & "refreshing" & quote & " to a newer model of engineering PC, you will want to provide a list of " & vbCrLf
Msg = Msg & "software applications you are currently using which you feel qualify you for an engineering machine. If " & vbCrLf
Msg = Msg & "your response falls within the Group parameters, then it will be documented and your machine can be " & vbCrLf
Msg = Msg & "refreshed to the latest engineering model. Otherwise, your machine will be refreshed to the standard model PC." & vbCrLf & vbCrLf
Msg = Msg & "For more than one PC assignment:" & vbCrLf
Msg = Msg & "This is the second PC assigned to you. You must provide a justification for the second PC. It your " & vbCrLf
Msg = Msg & "response falls within the Group parameters, then your model selection will be processed. Otherwise, the PC must be turned in." & vbCrLf & vbCrLf
Msg = Msg & "Many thanks for your attention to this matter." & vbCrLf & 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