From Rons Site:-
How To Prevent displaying the dialog that enables you Index
to send or not send the message
(Outlook or Outlook Express)
Ron de Bruin ( Last update 20 June 2004 )
Outlook Express
If you configure Outlook Express as the default mail handler (or simple
MAPI client) on the
General tab, Outlook Express processes requests by using Simple MAPI
calls.
Some viruses can exploit this functionality and spread by sending
copies of e-mail messages
that contain the virus to your contacts.
By default, Outlook Express 6 prevents e-mail messages from being sent
programmatically from
Outlook Express without your knowledge by displaying a dialog that
enables you to send or not
send the message.
If you regularly use an application that uses Simple MAPI calls to send
e-mail as yourself,
you may want to disable this protection as follows:
1 : Start Outlook Express, and then on the Tools menu, click Options.
2 : Click the Security tab, and then click to remove the check mark
from the warn me when other
applications try to send mail as me check box.
3 : Click OK to close the Options dialog box.
Outlook
Express ClickYes
http://www.contextmagic.com/express-clickyes/
Outlook Redemption
http://www.dimastr.com/redemption/
Instead of .Send in the code examples you can use this three lines
instead of .Send
( SendKeys is not always reliable and this will not work on every
computer)
Note: the S is from Send, if you not use a English version you must
change this letter.
You can only use this if you use the Outlook object model examples from
my site.
..Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%S"
CDO
There are no security warnings when you use CDO to send mail (my
favorite way to send mail)
http://www.rondebruin.nl/cdo.htm
Sending mail from Excel with CDO
Ron de Bruin (last update 25 Aug 2005)
Go to the Excel tips page
Read this!!!
This code will not work in Win 98 and ME.
You must be connected to the internet when you run a example.
It is possible that you get a Send error when you use one of the
examples.
AFAIK : This will happen if you haven't setup an account in Outlook
Express.
In that case the system doesn't know the name of your SMTP server.
If this happens you can use the commented blue lines in each example.
Don't forget to fill in the SMTP server name in each code sample where
it says "Fill in your SMTP server here"
When you also get the Authentication Required Error you can add this
three lines.
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= 1
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusername") =
"username"
..Item("
http://schemas.microsoft.com/cdo/configuration/sendpassword") =
"password"
Don't remove the TextBody line in the code. If you do you can't open
the attachment (bug in CDO).
If you don't want to have text in the body use this then .TextBody = ""
Sending a small message
Sending the ActiveWorkbook (attachment)
Sending a sheet or sheets as a attachment
Sending a sheet in the body of the mail
Sending the Selection in the body of the mail
Sending every sheet with address in A1 in the body of the mail
Sending every sheet with address in A1 as a attachment
Mail a message to each person in a range
Download a Sheet template on my SendMail page
Tips and links
What is CDO doing
The example code is using CDOSYS (CDO for Windows 2000).
It does not depend on MAPI or CDO and hence is dialog free
and does not use your mailbox to send email.
<You can send mail without a mail program or mail account>
Briefly to explain, this code builds the message and drops it
in the pickup directory, and SMTP service running on the machine
picks it up and send it out to the internet.
Why using CDO code instead of Outlook automation or
Application.SendMail in VBA.
1: It doesn't matter what Mail program you are using (It only use the
SMTP server).
2: It doesn't matter what Office version you are using (97...2003)
3: You can send a sheet in the body of the mail (some mail programs
can't do this)
4: You can send any file you like (Word, PDF, PowerPoint, TXT
files,....)
5: No Outlook Security warning anymore, really great if you are sending
a
lot of mail in a loop.
Sending a small message
Sub Mail_Small_Text_CDO()
Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Ron"" <
[email protected]>"
.Subject = "Important message"
.TextBody = strbody
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
End Sub
Tip: If you want to send the text from a txt file in the body then use
this line
..TextBody = GetBoiler("c:\test.txt") and copy this function in a
normal module
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sending the ActiveWorkbook (attachment)
You can't send the ActiveWorkbook with CDO.
That's why it use SaveCopyAs to save it with another name and send that
file.
Sub CDO_Send_Workbook()
Dim iMsg As Object
Dim iConf As Object
Dim wb As Workbook
Dim WBname As String
' Dim Flds As Variant
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
' It will save a copy of the file in C:/ with a Date and Time stamp
WBname = wb.Name & " " & Format(Now, "dd-mm-yy h-mm-ss") & ".xls"
wb.SaveCopyAs "C:/" & WBname
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Ron"" <
[email protected]>"
.Subject = "This is a test"
.TextBody = "This is the body text"
.AddAttachment "C:/" & WBname
.Send
End With
'If you not want to delete the file you send delete this line
Kill "C:/" & WBname
Set iMsg = Nothing
Set iConf = Nothing
Set wb = Nothing
Application.ScreenUpdating = True
End Sub
Sending a sheet or sheets in a new workbook as attachment
Sub CDO_Send_ActiveSheet()
Dim iMsg As Object
Dim iConf As Object
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim WBname As String
' Dim Flds As Variant
Application.ScreenUpdating = False
Set WB1 = ActiveWorkbook
ActiveSheet.Copy
'Other possibility's are
'Sheets("Sheet3").Copy
'Sheets(Array("Sheet1", "Sheet3")).Copy
Set WB2 = ActiveWorkbook
' It will save the new file with the ActiveSheet in C:/ with a Date
and Time stamp
WBname = "Part of " & WB1.Name & " " & Format(Now, "dd-mm-yy
h-mm-ss") & ".xls"
WB2.SaveAs "C:/" & WBname
WB2.Close False
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Ron"" <
[email protected]>"
.Subject = "This is a test"
.TextBody = "Hi there"
.AddAttachment "C:/" & WBname
.Send
End With
'If you not want to delete the file you send delete this line
Kill "C:/" & WBname
Set iMsg = Nothing
Set iConf = Nothing
Set WB1 = Nothing
Set WB2 = Nothing
Application.ScreenUpdating = True
End Sub
Sending a sheet in the body of the mail
Don't forget to copy the function also (It is not working without it).
Sub CDO_Send_ActiveSheet_Body()
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Ron"" <
[email protected]>"
.Subject = "This is a test"
.HTMLBody = SheetToHTML(ActiveSheet)
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
End Sub
Public Function SheetToHTML(sh As Worksheet)
'Function from Dick Kusleika his site
'
http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss")
& ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
End Function
Sending the selection in the body of the mail
Don't forget to copy the function also (It is not working without it).
Sub CDO_Send_Selection_Body()
Dim iMsg As Object
Dim iConf As Object
' Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
With iMsg
Set .Configuration = iConf
.To = "(e-mail address removed)"
.CC = ""
.BCC = ""
.From = """Ron"" <
[email protected]>"
.Subject = "This is a test"
.HTMLBody = RangetoHTML
.Send
End With
Set iMsg = Nothing
Set iConf = Nothing
End Sub
Public Function RangetoHTML()
' You can't use this function in Excel 97
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss")
& ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
Source:=Selection.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function
Sending every sheet with address in A1 in the body of the mail
This procedure will mail every Worksheet with an address in cell A1in
the body of the mail.
This way you can send each sheet to another person.
It does this by cycling through each worksheet in the workbook and
checking cell A1 for the @ character.
If found, a copy of the worksheet is made, and then sent by e-mail to
the address in cell A1.
And finally, the file is deleted from your hard disk
You need the SheetToHTML Function to use this sub.
Sub CDO_Mail_Every_Worksheet_Body()
Dim iMsg As Object
Dim iConf As Object
Dim ws As Worksheet
' Dim Flds As Variant
Application.ScreenUpdating = False
' Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
For Each ws In ThisWorkbook.Worksheets
If ws.Range("a1").Value Like "?*@?*.?*" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("a1").Value
.From = """Ron"" <
[email protected]>"
.Subject = "Body of sheet : " & ws.Name
.HTMLBody = SheetToHTML(ws)
.Send
End With
Set iMsg = Nothing
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
End Sub
Sending every sheet with address in A1 as a attachment
This procedure will mail every Worksheet with an address in cell A1.
This way you can send each sheet to another person.
It does this by cycling through each worksheet in the workbook and
checking cell A1 for the @ character.
If found, a copy of the worksheet is made, and then sent by e-mail to
the address in cell A1.
And finally, the file is deleted from your hard disk
Sub CDO_Mail_Every_Worksheet_File()
Dim iMsg As Object
Dim iConf As Object
Dim ws As Worksheet
Dim wb As Workbook
Dim WBname As String
' Dim Flds As Variant
Application.ScreenUpdating = False
' Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
For Each ws In ThisWorkbook.Worksheets
If ws.Range("a1").Value Like "?*@?*.?*" Then
ws.Copy
Set wb = ActiveWorkbook
WBname = "c:/Sheet " & ws.Name & ".xls"
wb.SaveAs WBname
wb.Close False
Set wb = Nothing
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("a1").Value
.From = """Ron"" <
[email protected]>"
.Subject = "Sheet: " & ws.Name
.AddAttachment WBname
.TextBody = "Hi there"
.Send
End With
Set iMsg = Nothing
Kill WBname
End If
Next ws
Set iConf = Nothing
Application.ScreenUpdating = True
End Sub
Mail a message to each person in a range
Make a list in Sheet("Sheet1") with
In column A the names of the people
In column B the E-mail addresses
In column C yes or no , if the value is yes a mail will be send
The Macro will loop through each row in Sheet1 and if there is a E-mail
address in column B
and "yes" in column C it will create a mail with a reminder like this
for each person.
Dear Jelle (Jelle is a name in column A for example)
Please contact us to discuss bringing your account up to date
Sub Message()
Dim iMsg As Object
Dim iConf As Object
Dim cell As Range
' Dim Flds As Variant
Application.ScreenUpdating = False
' Set iConf = CreateObject("CDO.Configuration")
' iConf.Load -1 ' CDO Source Defaults
' Set Flds = iConf.Fields
' With Flds
'
..Item("
http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"Fill in your SMTP server here"
'
..Item("
http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= 25
' .Update
' End With
For Each cell In
Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Offset(0, 1).Value <> "" Then
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0,
1).Value) = "yes" Then
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = cell.Value
.From = """Ron"" <
[email protected]>"
.Subject = "Reminder"
.TextBody = "Dear " & cell.Offset(0, -1).Value &
vbNewLine & vbNewLine & _
"Please contact us to discuss bringing
your account up to date"
.Send
End With
Set iMsg = Nothing
End If
End If
Next cell
Set iConf = Nothing
Application.ScreenUpdating = True
End Sub
Tips and links
Set importance/priority and request read receipt
For importance/priority you can add this in the With iMsg part of the
macro before .Send
' Set importance high, will work if the receiver have Outlook
.Fields("urn:schemas:httpmail:importance") = 2
' Set Priority high, will work if the receiver have Outlook Express
.Fields("urn:schemas:mailheader:X-Priority") = 1
' Update fields
.Fields.Update
If you want to add a request read receipt then you can use this.
Note: this is only working if the receiver have Outlook Express.
' Request read receipt if the receiver have Outlook Express
.Fields("urn:schemas:mailheader:return-receipt-to") =
"(e-mail address removed)"
' Update fields
.Fields.Update
Changing the To line
The examples below will use the cells from sheets("Sheet1") in the
ActiveWorkbook
It is possible that you must use ThisWorkbook or something else in your
code to use it.
If you want to mail to all E-mail addresses in column C use this code
instead of .To = "(e-mail address removed)"
Dim cell As Range
Dim strto As String
For Each cell In
Sheets("Sheet1").Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)
Change the To line to .To = strto
Or to more people
..To = "(e-mail address removed);
[email protected]"
Or you can use a address in a cell like this
.To = Sheets("Sheet1").Range("C1").Value
Change the Body line
If you want to add more text to the body then
instead of .TextBody = "This is the body text" use this.
Dim strbody As String
strbody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
Or use this if you want to use cell values
Dim cell As Range
Dim strbody As String
For Each cell In Sheets("Sheet1").Range("C1:C20")
strbody = strbody & cell.Value & vbNewLine
Next
Or this one
Dim strbody As String
With Sheets("Sheet1")
strbody = "Hi there" & vbNewLine & vbNewLine & _
.Range("A1") & vbNewLine & _
.Range("A2") & vbNewLine & _
.Range("A3") & vbNewLine & _
.Range("A4")
End With
Change the Body line to .TextBody = strbody to use the string.
You can also send links in the body
..TextBody = "file://Yourcomputer/YourFolder/Week2.xls"
'If there are spaces use %20
..TextBody = "file://Yourcomputer/YourFolder/Week%202.xls"
'Example for a file on a website
..TextBody = "
http://www.rondebruin.nl/files/EasyFilter.zip"
If you want to create emails that are formatted you can use HTMLBody
(Office 2000 and up) instead of TextBody .
You can find a lot of WebPages on the internet with more HTML tags
examples.
.HTMLBody = "<H3><B>Dear Ron de Bruin</B></H3>" & _
"Please visit this website to download an
update.<BR>" & _
"<A HREF=""
http://www.rondebruin.nl/"">Ron's Excel
Page</A>"
Copy the cells as values
If you want to paste as values the sheet must be unprotect!!!!!
Or Unprotect and Protect the sheet in the Sub also.
Below one of this lines in the example subs (if you copy one Sheet)
ws.copy
Activesheet.copy
Add this :
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
Application.CutCopyMode = False
If you copy more sheets in the newly created workbook
(Sheets(Array("Sheet1", "Sheet3")).Copy)
Then use this after the copy line.
Worksheets.Select
Cells.Copy
Cells.PasteSpecial xlPasteValues
Cells(1).Select
Worksheets(1).Select
Application.CutCopyMode = False
Test if you are online
You can use code like this in your subroutine to avoid errors
if you are not online (only with dial up connections)
For checking other connections check out this website
http://vbnet.mvps.org/
Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (lpdwFlags As Long, _
ByVal dwReserved As Long) As Boolean
Function IsConnected() As Boolean
Dim Stat As Long
IsConnected = (InternetGetConnectedState(Stat, 0&) <> 0)
End Function
Sub Test()
' Randy Birch
If IsConnected = True Then
MsgBox "Copy your mail code here"
Else
MsgBox "You can't use this subroutine because you are not
online"
End If
End Sub
Links to more information about CDO for windows 2000
MSDN
Search for "CDO for Windows 2000" on MSDN
Paul R. Sadowski
http://www.paulsadowski.com/WSH/cdo.htm
www.aspfaq.com
http://www.aspfaq.com/show.asp?id=2026