Option Explicit

 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 ' Function SendSafeMail: Send an e-mail from a VBA application without security warning.
 '
 ' Created in 2006 by Nik Tuzov, Purdue University Computational Finance Program
 '                    E-mail: ntuzov@purdue.edu  Web: http://www.stat.purdue.edu/~ntuzov/
 ' You are welcome to use this code for any purpose but please leave this header intact.

 '                            How to use this function
 
 ' This function uses Outlook Redemption to circumvent the security warning generated by
 ' MS Outlook 2003 "A program is trying to automatically send e-mail on your behalf..."
 ' thus making it possible to send an email from a VBA application without human intervention.
 '
 ' First you have to install Outlook Redemption (it can be downloaded for free from
 ' http://www.dimastr.com/redemption/ ,  "Developer Version").
 ' Redemption Outlook Library and Microsoft Outlook Library should be visible in
 ' Tools -> References of your VBA Editor, but you don't have to check them
 ' (this code uses late binding).
 
 ' After that, SendSafeMail is ready to use, and you can see how its parameters work by
 ' running the procedure CheckSendSafeMail() with your own set of parameters. It has been tried
 ' with 2003 MS VBA for Excel, Word and Outlook, along with MS Outlook 2007 and it works fine.
 
 ' Note that To/CC/BCC/Attachments parameters can contain multiple items if you separate
 ' them by a semicolon. Attachment name(s) should contain the full path.
 '
 ' Error handling: the function returns True if all is fine. Otherwise, it returns False
 ' and an error message is shown. If you don't  want error message comment out the MsgBox
 ' statement in the ErrorHandler.
 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub CheckSendSafeMail()

    ' change these 6 parameters to test Function SendSafeMail:
    Const AddrTo As String = "address1@something.com; address2@something.com"
    Const AddrCC As String = "addr3@somth.com"
    Const AddrBCC As String = "addr4@somth.com; addr5@somth.com"
    Const Subj As String = "Test SendSafeMail"
    
    Const MsgBody As String = "Hi there!" & vbCrLf & vbCrLf & "This is from SendSafeMail." & vbCrLf & vbCrLf & _
                              "Sincerely," & vbCrLf & "Nik Tuzov" & vbCrLf & "http://www.stat.purdue.edu/~ntuzov/"
                              
    Const Attachments As String = "H:\My Documents\file1.txt" & ";" & "H:\My Documents\file2.txt"
    ' now call SendSafeMail:
    Call SendSafeMail(AddrTo, AddrCC, AddrBCC, Subj, MsgBody, Attachments)
    
End Sub

Public Function SendSafeMail(AddrTo As String, _
                             AddrCC As String, _
                             AddrBCC As String, _
                             Subj As String, _
                             MsgBody As String, _
                Optional Attachments As String) As Boolean
   
    Dim OutlookApp As Object    ' Outlook application to open
    Dim MItem As Object         ' Outlook mail item
    Dim objSafeMail As Object   ' Redemption mail item
    Dim AttachArray() As String ' Contains attachment file names
    Dim AttachItem As Variant   ' Single attachment
    Dim Success As Boolean      ' Whether the function completed successfully
    
    On Error GoTo ErrorHandler:
    
    'Create Outlook object:
    Set OutlookApp = CreateObject("Outlook.Application")
    'Create Outlook Mail Item:
    Set MItem = OutlookApp.CreateItem(0)
    With MItem
        .To = AddrTo
        .Subject = Subj
        .Body = MsgBody
        .CC = AddrCC
        .BCC = AddrBCC
        'Add attachments, if any:
        AttachArray = Split(Attachments, ";")
        For Each AttachItem In AttachArray
            .Attachments.Add CStr(Trim(AttachItem))
        Next AttachItem
        .Save
    End With
    
    ' Now send email using Redemption:
    Set objSafeMail = CreateObject("Redemption.SafeMailItem")
    objSafeMail.Item = MItem
    objSafeMail.Send
    ' Function completes successfully:
    Success = True
    
ExitRoutine:
    Set OutlookApp = Nothing
    SendSafeMail = Success
    Exit Function
    
ErrorHandler:
     ' comment out MsgBox statement if you don't want to see an error message:
    MsgBox "An error has occured while trying to send email via SendSafeMail" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, vbApplicationModal + vbCritical
            
    Resume ExitRoutine
                                
End Function