ExcelBanter - help with ron bruin site - preventing outlook secuirty help needed

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 = "
.CC = ""
.BCC = ""
.From = """Ron"" "
.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 = "
.CC = ""
.BCC = ""
.From = """Ron"" "
.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 = "
.CC = ""
.BCC = ""
.From = """Ron"" "
.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 = "
.CC = ""
.BCC = ""
.From = """Ron"" "
.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 = "
.CC = ""
.BCC = ""
.From = """Ron"" "
.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"" "
.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"" "
.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(x lCellTypeConstants)
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"" "
.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") =
"

' 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 = "

Dim cell As Range
Dim strto As String
For Each cell In
Sheets("Sheet1").Columns("C").Cells.SpecialCells(x lCellTypeConstants)
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 = "

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<BDear 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