VBA實現outlook自動發信 2

主要的問題：
通過vba觸發outlook發郵件的時候，系統會捕捉到不是由outlook本身發起的請求，

會自動彈出一個對話框，要求確認為yes后，才會發信；

這樣就不能實現無人自動發信了。

查了很多資料，最終把問題解決了，總結如下：

0，    環境是日文的windowsXP，office2003；為了以后看着方便，把注釋盡量都用英文寫了；
1，    我們需要在outlook中設置一個宏，並把outlook的安全級別設置為中或者低，記得重啟outlook；
2，    這個宏的內容可以參考附錄1，這是某個老外寫的，有興趣的可以去他的主頁看看，不知道還在不在；國內很多外包公司是很難上外網的，我下班在家不睡覺搞這個容易嘛我；
3，    具體的添加方法：打開outlook，打開宏編輯，選取outlook的第一個自帶宏session，把附錄1的內容拷貝進去；
4，    附錄1實際對outlook對象添加了一個方法；目的呢，由於是之前outlook判斷不是自身發起的請求將彈出對話框；而添加到了outlook自身之后，就回避了這個問題；當然有人說通過vb捕捉彈出窗口，發起BM_CLICK事件，而不是BTNclick   btnHwnd事件，也可以實現自動點擊yes自動發信；
5，    繼續老外的方法，打開需要觸發的文件，比如execl或者access等等，把附錄2的內容拷貝進去；注意修改to地址，郵件名，郵件體，附件等等；
6，    在公司有可能需要把認證先通過后，自己測試后比較為好。

那么，這樣做了也實現不了自動發信，觸發的timer什么的，我也有，就不貼了，實在拿不出手。

-----------附錄1-----------

Option Explicit

' Code: Send E-mail without Security Warnings ' OUTLOOK 2003 VBA CODE FOR 'ThisOutlookSession' MODULE ' (c) 2005 Wayne Phillips (http://www.everythingaccess.com) ' Written 07/05/2005 ' Last updated v1.4 - 26/03/2008 '
' Please read the full tutorial here:
' http://www.everythingaccess.com/tutorials.asp?ID=112
'
' Please leave the copyright notices in place - Thank you.

Private Sub Application_Startup()

    'IGNORE - This forces the VBA project to open and be accessible 
    '         using automation at any point after startup

End Sub

' FnSendMailSafe
' --------------
' Simply sends an e-mail using Outlook/Simple MAPI.
' Calling this function by Automation will prevent the warnings ' 'A program is trying to send a mesage on your behalf...'
' Also features optional HTML message body and attachments by file path. 
'
' The To/CC/BCC/Attachments function parameters can contain multiple items ' by seperating them with a semicolon. (e.g. for the strTo parameter, ' '[e-mail]; [e-mail]' would be acceptable for sending to ' multiple recipients. 
'                   
Public Function FnSendMailSafe(strTo As String, _
                                strCC As String, _
                                strBCC As String, _
                                strSubject As String, _
                                strMessageBody As String, _
                                Optional strAttachments As String) As Boolean

' (c) 2005 Wayne Phillips - Written 07/05/2005 ' Last updated 26/03/2008 - Bugfix for empty recipient strings ' http://www.everythingaccess.com '
' You are free to use this code within your application(s) ' as long as the copyright notice and this message remains intact.

On Error GoTo ErrorHandler:

    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient
    
    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim strEmailAddress As String
    Dim strAttachmentPath As String
    
    Dim blnSuccessful As Boolean

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session
    
    If Not MAPISession Is Nothing Then

      'Logon to the MAPI session
      MAPISession.Logon , , True, False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
      If Not MAPIFolder Is Nothing Then

        'Create a new mail item in the "Outbox" folder
        Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
        If Not MAPIMailItem Is Nothing Then
          
          With MAPIMailItem

            'Create the recipients TO
                TempArray = Split(strTo, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olTo
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Create the recipients CC
                TempArray = Split(strCC, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olCC
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Create the recipients BCC
                TempArray = Split(strBCC, ";")
                For Each varArrayItem In TempArray
                
                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olBCC
                        Set oRecipient = Nothing
                    End If
                
                Next varArrayItem
            
            'Set the message SUBJECT
                .Subject = strSubject
            
            'Set the message BODY (HTML or plain text)
                If StrComp(Left(strMessageBody, 6), "<HTML>", _
                            vbTextCompare) = 0 Then
                    .HTMLBody = strMessageBody
                Else
                    .Body = strMessageBody
                End If

            'Add any specified attachments
                TempArray = Split(strAttachments, ";")
                For Each varArrayItem In TempArray
                
                    strAttachmentPath = Trim(varArrayItem)
                    If Len(strAttachmentPath) > 0 Then
                        .Attachments.Add strAttachmentPath
                    End If
                
                Next varArrayItem

            .Send 'The message will remain in the outbox if this fails

            Set MAPIMailItem = Nothing
            
          End With

        End If

        Set MAPIFolder = Nothing
      
      End If

      MAPISession.Logoff
      
    End If
    
    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True
    
ExitRoutine:
    Set MAPISession = Nothing
    FnSendMailSafe = blnSuccessful
    
    Exit Function
    
ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function " & _
            "FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, _
                vbApplicationModal + vbCritical
    Resume ExitRoutine

End Function

 

-----------附錄2-----------

Option Explicit

' ACCESS VBA MODULE: Send E-mail without Security Warning ' (c) 2005 Wayne Phillips (http://www.everythingaccess.com) ' Written 07/05/2005 ' Last updated v1.3 - 11/11/2005 '
' Please read the full tutorial & code here:
' http://www.everythingaccess.com/tutorials.asp?ID=112
'
' Please leave the copyright notices in place - Thank you.

' This is a test function! - replace the e-mail addresses ' with your own before executing!!
' (CC/BCC can be blank strings, attachments string is optional)

Sub FnTestSafeSendEmail()
    Dim blnSuccessful As Boolean
    Dim strHTML As String
        
    strHTML = "<html>" & _
               "<body>" & _
               "My <b><i>HTML</i></b> message text!" & _
               "</body>" & _
               "</html>" 
    blnSuccessful = FnSafeSendEmail("[e-mail]", _
                                    "My Message Subject", _
                                    strHTML)
    
    'A more complex example...    
    'blnSuccessful = FnSafeSendEmail( _
                        "[e-mail]; [e-mail]", _
                        "My Message Subject", _     
                        strHTML, _    
                        "C:\MyAttachFile1.txt; C:\MyAttachFile2.txt", _ 
                        "[e-mail]", _  
                        "[e-mail]")

    If blnSuccessful Then
    
        MsgBox "E-mail message sent successfully!"
        
    Else
    
        MsgBox "Failed to send e-mail!"
    
    End If

End Sub


'This is the procedure that calls the exposed Outlook VBA function...
Public Function FnSafeSendEmail(strTo As String, _
                    strSubject As String, _
                    strMessageBody As String, _
                    Optional strAttachmentPaths As String, _
                    Optional strCC As String, _
                    Optional strBCC As String) As Boolean

    Dim objOutlook As Object ' Note: Must be late-binding.
    Dim objNameSpace As Object
    Dim objExplorer As Object
    Dim blnSuccessful As Boolean
    Dim blnNewInstance As Boolean
    
    'Is an instance of Outlook already open that we can bind to?
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If objOutlook Is Nothing Then
    
        'Outlook isn't already running - create a new instance...
        Set objOutlook = CreateObject("Outlook.Application")
        blnNewInstance = True    
        'We need to instantiate the Visual Basic environment... (messy)
        Set objNameSpace = objOutlook.GetNamespace("MAPI")
        Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)
        objExplorer.CommandBars.FindControl(, 1695).Execute
                
        objExplorer.Close
                
        Set objNameSpace = Nothing
        Set objExplorer = Nothing
        
    End If

    blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _
                                                strSubject, strMessageBody, _
                                                strAttachmentPaths)
                                
    If blnNewInstance = True Then objOutlook.Quit
    Set objOutlook = Nothing
    
    FnSafeSendEmail = blnSuccessful
    
End Function