VBA microsoft security issue

[MartinST]

I have the following code that send the active workbook to several recipients, how can I overcome the security issue whereby Outlook (2003) pops up a message for the user to grant permission before sending the mail to the recipients as this message appears for each recipient in the mailing list. Is there a way to overcome this or an alternative mailing method?

Sub Create_Mail_From_List()

Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

ActiveSheet.Unprotect
Application.ScreenUpdating = False

'Copy & Paste names for VBA to recognize the mailing list
Range("G4:I19").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "I").Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next

With OutMail
.To = cell.Value
.Subject = "Procedure"
.Body = "Dear " & Cells(cell.Row, "G").Value _
& vbNewLine & vbNewLine & _
"Please find attached a new procedure."
.Attachments.Add ActiveWorkbook.FullName

.Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing

'Insert formulas again for mailing list
Range("G3:I3").Select
Selection.AutoFill Destination:=Range("G3:I19"), Type:=xlFillDefault
Range("d3").Select

Application.ScreenUpdating = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlUnlockedCells
End Sub

 

[daverunt]

There's CDO mail.

http://www.rondebruin.nl/cdo.htm

An example here:

http://www.mrexcel.com/forum/showthread.php?t=526984

You could try 'SendKeys'
Search for examples on this forum.

http://msdn.microsoft.com/en-us/library/aa202943(v=office.10).aspx

 

[MartinST]

Thanks I will have a look at the suggested references.