I work with a program that allows instructors to submit referrals for college students who are struggling academically. We then reach out to students and suggest resources that may benefit them. I'm using a spreadsheet to track our call outcomes with students and need to be able to automate follow-up emails to faculty alerting them to the outcome of our calls. I'm using the following code to do that, but every time I run the code it will email all faculty on the list.
Is there a code to attach to the bottom of this to identify when an email has been sent at the end of each row? If so, is there a code to have Excel/Outlook only send emails to users who have not been emailed? Does this make sense?
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 = 2 To 4 'data in rows 2-4
' Get the email address
Email = Cells(r, 9)
' Message subject
Subj = "Success Connect Referral Update"
' Compose the message
Msg = ""
Msg = Msg & "Hello "
Msg = Msg & "Student Success Center Peer Callers attempted to reach out to: "
Msg = Msg & Cells(r, 1).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "The following interaction occured: "
Msg = Msg & Cells(r, 7).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "Mike Dial" & vbCrLf
Msg = Msg & "Coordinator of Early Intervention" & vbCrLf
Msg = Msg & "Student Success Center"
' 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
Add a new "E-Mailed" column, say column 10 (J) after the email address.
When the email is sent set the cells value to something, check it the next time round.
For r = 2 To 4 'data in rows 2-4
if Cells(r, 10).Value = "" then
' Get the email address
Email = Cells(r, 9)
.. rest of code ..
Cells(r, 10).Value = "Sent: " & Now
end if
Next r
Using sendkeys method is really bad and should be avoided. Given that you have both Excel and Outlook, you can develop a VBA procedure from within Excel that will scan your columns in Excel and send the email based on a certain criteria.
Related
I'm a novice programmer and I'm making a program that will send individualized emails to merchandisers with a list when they've violated our pricing policies. I've gotten sending the email and filling in most of the merchandiser-specific information to work, but I'm trying to include URL links so they can view their violations in detail.
Different merchants will have different numbers of violations, so I added this while loop at the end so it adds only those URLs that are pertinent to them. This loop is nested inside a For loop to the end of the data.
Do While ((Range("B" & n).Value <> "") And (Range("A" & n).Value = ""))
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
If the value in B row n is not empty and A row n is it should add the URL from column 21 on row n to the bottom of the message and then stop when those conditions aren't met (when we're at a new merchant).
Currently, it will only return the value for column 21 from the first row and nothing else, despite appearing to loop.
I've ran the debugger to see if the loop isn't incrementing like it should, but that seems to be working. I've also tried formatting it as a Do Until Loop, using Cells(n, 1).Value and Cells(n, 2).Value for the reference addresses and a Do While with one of the conditions and a nested If to create the other. Nothing has worked.
I can include more of my code if that would be helpful. Please excuse any sloppiness in my code (I know there are plenty). I'm an accountant, not a programmer.
Here is the entirety of my code. Full disclosure and in the interest of plagarism, I got the majority of it from Kutools on Extendoffice.com and have just modified it to my needs. I've also edited out the actual text of the email body.
#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 SendEMail()
'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 n As Long
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:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 21 Then
MsgBox " Regional format error, please check", , "Kutools for Excel"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
n = i + 2
If InStr(1, xRg.Cells(i, 13).Value, "#") > 0 Then
' Get the email address
xEmail = xRg.Cells(i, 13)
' Message subject
xSubj = "MAPP Violation"
' Compose the message
xMsg = ""
xMsg = xMsg & "Text" &vbCrLf
Do While ((Range("B" & n).Value <> "") And (Range("A" & n).Value = ""))
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
' 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"
End If
Next
End Sub
Again, I apologize for the sloppiness. I know the formatting is mediocre and I can make the Do While Loop as a separate sub and call it. I learned basic C++ five years ago and haven't retained much of my knowledge or etiquette. I wasn't planning on anyone else seeing my code so I wasn't going to clean it up until I got it working.
Currently, it's set up so you select the total data range for it to look at. I've kept it that way so I could test it without sending tons of emails to unsuspecting victims. Once I have it working I'll change xRg to be the last populated row and column.
Here's what the data I'm using looks like. I've edited the merchant information to protect their privacy.
enter image description here
Suggested fix:
Sub SendEMail()
Dim xEmail As String, xSubj As String, xMsg As String, xURL As String
Dim i As Long, n As Long, k As Double
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:", _
"Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 21 Then
MsgBox " Regional format error, please check", , "Kutools for Excel"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
If InStr(1, xRg.Cells(i, 13).Value, "#") > 0 Then
xEmail = xRg.Cells(i, 13) 'Get the email address
xSubj = "MAPP Violation" 'Message subject
xMsg = "Text" & vbCrLf
n = i + 2
'### use xRg.Cells() not Range() here...
Do While xRg.Cells(n, "B").Value <> "" And xRg.Cells(n, "A").Value = ""
xMsg = xMsg & xRg.Cells(n, 21) & vbCrLf
n = n + 1
Loop
xSubj = Replace(xSubj, " ", "%20") 'Replace spaces with %20 (hex)
xMsg = Replace(xMsg, " ", "%20")
xMsg = Replace(xMsg, vbCrLf, "%0D%0A") 'Replace carriage returns with %0D%0A (hex)
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg 'Create the URL
'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"
End If
Next i
End Sub
My issue seems to have been a that the URLs were too long and I reached a character limit which caused errors when exporting to Outlook. I ended up rewriting my code in HTML format so I could add the URLs as hyperlinks and that worked.
I am creating a spreadsheet for a warehouse to log problems with items
they receive. The warehouse staff will input the following ' criteria for
email' into each cell
A IS Reference number,
C IS Part number,
G IS Order number,
N IS Issue with Part,
R IS their email address,
T IS Expediter email address,
Now I have made column U the cells that when the warehouse staff double
click, it brings up an email with the address in T and the subject of
A,C,G. The body of the text then includes a prompt for them to look at
the spreadsheet.
I want to be able to then make the column X do the same double click
function, but instead of emailing the same message as when you double
click column U, the expediters get a different address (from column R)
and a different subject and body to tell the warehouse staff they have
solved the issue.
I have written the code to allow column U to be double clicked and the
email box will appear, and it works amazingly! But i am stuck on how to
do the same for column X. I have tried copying and pasting the original
code underneath itself and changing the parameters to suit column X, but
excel VBA seems to treat it as if the code wasn't there?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim sRef As String
Dim sMat As String
Dim sIssue As String
Dim sMeYou As String
Dim sTo As String
Dim sBody As String
Dim sOrder As String
Dim sSend As String
Dim bSucces As Boolean
On Error GoTo Err_Mail
If Not Intersect(Target, Range("U:U,X:X")) Is Nothing Then
With Target
sRef = .Offset(0, -20).Value
sMat = .Offset(0, -17).Value
sIssue = .Offset(0, -7).Value
sMeYou = .Offset(0, -1).Value
sTo = .Offset(0, -1).Value
sSend = .offset(0,-3).value
sOrder = .Offset(0, -14).Value
End With
Cancel = True
Else
Cancel = False
Exit Sub
End If
If sMeYou = "expediteremail#warehouse.com" Then
bSucces = CreateMailItem(sTo, "Gareth," & vbNewLine & vbNewLine & "A
new part has been added to the Plant 2200 Parts Register." & vbNewLine &
vbNewLine & "Please open up the workbook to review." & vbNewLine &
vbNewLine & "Issue relates to", sOrder, sIssue, _
sRef, sMat, 2, False)
ElseIf sMeYou = "expediteremail2#warehouse.com" Then
bSucces = CreateMailItem(sTo, "Gail," & vbNewLine & vbNewLine & "A
new part has been added to the Plant 2200 Parts Register." & vbNewLine &
vbNewLine & "Please open up the workbook to review." & vbNewLine &
vbNewLine & "Issue relates to", sOrder, sIssue, _
sRef, sMat, 2, False)
ElseIf sSend = "harrywood#siemens.com" Then
bSucces = CreateMailItem(sSend, "Team please look at this", sOrder, sIssue, sRef, sMat, 2, False)
End If
If bSucces Then
Target.Offset(0, 26).Value = Now()
Else
MsgBox "Please fill in all Part details before sending email"
End If
Exit Sub
Err_Mail:
MsgBox "Sorry there has been an error, please contact Harry Wood
(Quality)"
End Sub
Public Function CreateMailItem(sTo As String, _
sBody As String, _
sOrder As String, _
sIssue As String, _
sRef As String, _
sMat As String, _
iImportance As Integer, _
bReceipt As Boolean) As Boolean
Dim oOutlookApp As Object
Dim oOutlookMail As Object
CreateMailItem = False
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
If Not oOutlookApp Is Nothing Then
Set oOutlookMail = oOutlookApp.CreateItem(0)
If Not oOutlookMail Is Nothing Then
With oOutlookMail
.To = sTo
.Subject = "Ref: " & sRef & " Part Number: " &
sMat & " Order Number: " & sOrder
.Body = sBody & vbCr & sIssue
.Importance = iImportance
.ReadReceiptRequested = bReceipt
.Display
CreateMailItem = True
End With
End If
End If
Set oOutlookMail = Nothing
Set oOutlookApp = Nothing
End Function
would copying this code again and changing the parameters actually work
or do I need to do something else? I am now stuck in my own limitations
of vba knowledge.
Try changing:
If Target.Column = 21 Then
To:
If Not Intersect(Target, Range("U:U,X:X")) Is Nothing Then
I modified the code here - https://www.extendoffice.com/documents/excel/3560-excel-send-personalized-email.html
If the text in the cell is long, it is truncated.
I tried increasing the application time value to 0.20, but that did nothing. It got truncated at the same point.
#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 SendEMail()
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:", "navneesi", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 1)
' Message subject
xSubj = "Validation Assignment"
' Compose the message
xMsg = ""
xMsg = xMsg & "Validation Assignment: " & vbCrLf & vbCrLf
xMsg = xMsg & " Order ID: " & xRg.Cells(i, 2).Text & vbCrLf
xMsg = xMsg & " Marketplace ID: " & xRg.Cells(i, 3).Text & vbCrLf
xMsg = xMsg & " Order Day: " & xRg.Cells(i, 4).Text & vbCrLf
xMsg = xMsg & " Seller ID: " & xRg.Cells(i, 5).Text & vbCrLf
xMsg = xMsg & " Product Code: " & xRg.Cells(i, 6).Text & vbCrLf
xMsg = xMsg & " Item Name: " & xRg.Cells(i, 7).Text & vbCrLf
xMsg = xMsg & " Defect Source: " & xRg.Cells(i, 8).Text & vbCrLf
xMsg = xMsg & " Defect Day: " & xRg.Cells(i, 9).Text & vbCrLf
xMsg = xMsg & " Defect Text: " & xRg.Cells(i, 10).Text & vbCrLf
' 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
Well, 1390 doesn't seem like any kind of restriction that I have ever heard about. Maybe 255 characters, or a variable-length string of up to approximately 2 billion (2^31) characters, etc. Can you try doing it this way?
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
NOTE:
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Most relevant URL:
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
Parent URL:
https://www.rondebruin.nl/win/s1/outlook/mail.htm
Found a fix. Instead of usingCells(i, 5).Text use Cells(i, 5).Value.
This makes sure the cell content is sent to outlook as it is instead of converting it to text first which gives rise to issues. (The code in the question was also unable to render chinese text.)
Also, instead of executing a mail to url, I included the object library for outlook and declared the object for outlook application and for mail item. Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
I have a list of 1000+ of customers dowloaded from SAP. I have a macro for sending monthly statements (pdfs about outstanding invoices or open cases).
My macro grabs email address from column A, the next column is Subject of email and last one is body of the email:
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A1000")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.Subject = cell.Offset(0, 1).Value
.Body = cell.Offset(0, 2).Value
.Attachments.Add cell.Offset(0, 3).Value
'display will show you email before it is sent, replace it with "send" and it will sent email without displaying
.send
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
It works but I want to adapt it.
How can I add signature which is for example stored in .htm on desktop (to have it changed for all of my colleagues to personalize emails).
Emails contain a list of delayed invoices also from report from SAP - customer has specific SAP number.
I need to add to the email all open items which contain the specific customer number (named as account).
Regarding part 1, you can convert HTML to an Outlook template file (.oft) as per the instructions here:
http://smallbusiness.chron.com/convert-html-oft-52249.html
That template file can then be used using the Application.CreateItemFromTemplate method as per the docs below:
https://msdn.microsoft.com/en-us/vba/outlook-vba/articles/application-createitemfromtemplate-method-outlook
Regarding part 2, to include table data in the email just use something like below:
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0) ' or use the template method specified in pt 1.
Dim html As String: html = "<html><body><table>"
Dim row As String
' the two lines below should be changed to include data from your excel
' table when filtered. Repeat the two lines below for the rows as required
row = "<tr><td> .... </td></tr>"
html = html & row
' once the rows are processed, close off the html tags
html = html & "</table></body></html>"
With OutMail
.To = "email_address#email.com"
.CC = ""
.BCC = ""
.HTMLBody = html
.BodyFormat = olFormatHTML
.Display ' or .Send
End With
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
Sub SendEmail()
Dim email As String
Dim subject As String
Dim msg As String
Dim mailURL As String
Dim i As Integer
Dim tableRange As Range
On Error Resume Next
Set tableRange = Application.InputBox("Please select the data range:", "Custom Email Sender", Type:=8) ''Type 8 is cell reference
If tableRange Is Nothing Then Exit Sub ''A little error handeling incase someone accidentily doesn't select a range
If tableRange.Columns.Count <> 4 Then
MsgBox "You must select 4 columns of data. Please try again"
Exit Sub
End If
For i = 1 To tableRange.Rows.Count
email = tableRange.Cells(i, 3)
subject = "Thank you for your Recent Purchase at Think Forward Computer Services"
''Create the message
msg = "Hi " & tableRange.Cells(i, 1) & ", "
msg = msg & "We want to thank you for your recent business at our store! We really appreciate it."
msg = msg & "If you have any questions or concerns about your " & tableRange.Cells(i, 4) & " we're here to help. Just reply to this email at anytime " _
& "or call us at 555-555-5555 between the hours of 8am - 8pm " & vbNewLine & vbNewLine & "Thanks Again, " & vbNewLine & "Think Forward Computer Services"
mailURL = "mailto:" & email & "?subject=" & subject & "&body=" & msg
Call Shell(sCmd, vbNormalFocus)
''Send the Email
ShellExecute 0&, vbNullString, mailURL, vbNullString, vbNullString, vbNormalFocus
''Wait for email client to open
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next
End Sub
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 = 2 To 2000 'data in rows 2-4
' Get the email address
Email = Cells(r, 6)
' Message subject
Subj = "bug"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 6) & "," & vbCrLf & vbCrLf
Msg = Msg & "Please Validate thebug Waiting on You "
Msg = Msg & Cells(r, 1).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "S" & vbCrLf
Msg = Msg & "RTS"
' 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
help me debug this, its going to infinity loop