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

  1 Option Explicit
  2 
  3 ' 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 '
  4 ' Please read the full tutorial here:
  5 ' http://www.everythingaccess.com/tutorials.asp?ID=112
  6 '
  7 ' Please leave the copyright notices in place - Thank you.
  8 
  9 Private Sub Application_Startup()
 10 
 11     'IGNORE - This forces the VBA project to open and be accessible 
 12     '         using automation at any point after startup
 13 
 14 End Sub
 15 
 16 ' FnSendMailSafe
 17 ' --------------
 18 ' Simply sends an e-mail using Outlook/Simple MAPI.
 19 ' Calling this function by Automation will prevent the warnings ' 'A program is trying to send a mesage on your behalf...'
 20 ' Also features optional HTML message body and attachments by file path. 
 21 '
 22 ' The To/CC/BCC/Attachments function parameters can contain multiple items ' by seperating them with a semicolon. (e.g. for the strTo parameter, ' 'test@test.com; test2@test.com' would be acceptable for sending to ' multiple recipients. 
 23 '                   
 24 Public Function FnSendMailSafe(strTo As String, _
 25                                 strCC As String, _
 26                                 strBCC As String, _
 27                                 strSubject As String, _
 28                                 strMessageBody As String, _
 29                                 Optional strAttachments As String) As Boolean
 30 
 31 ' (c) 2005 Wayne Phillips - Written 07/05/2005 ' Last updated 26/03/2008 - Bugfix for empty recipient strings ' http://www.everythingaccess.com '
 32 ' You are free to use this code within your application(s) ' as long as the copyright notice and this message remains intact.
 33 
 34 On Error GoTo ErrorHandler:
 35 
 36     Dim MAPISession As Outlook.NameSpace
 37     Dim MAPIFolder As Outlook.MAPIFolder
 38     Dim MAPIMailItem As Outlook.MailItem
 39     Dim oRecipient As Outlook.Recipient
 40     
 41     Dim TempArray() As String
 42     Dim varArrayItem As Variant
 43     Dim strEmailAddress As String
 44     Dim strAttachmentPath As String
 45     
 46     Dim blnSuccessful As Boolean
 47 
 48     'Get the MAPI NameSpace object
 49     Set MAPISession = Application.Session
 50     
 51     If Not MAPISession Is Nothing Then
 52 
 53       'Logon to the MAPI session
 54       MAPISession.Logon , , True, False
 55 
 56       'Create a pointer to the Outbox folder
 57       Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
 58       If Not MAPIFolder Is Nothing Then
 59 
 60         'Create a new mail item in the "Outbox" folder
 61         Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
 62         If Not MAPIMailItem Is Nothing Then
 63           
 64           With MAPIMailItem
 65 
 66             'Create the recipients TO
 67                 TempArray = Split(strTo, ";")
 68                 For Each varArrayItem In TempArray
 69                 
 70                     strEmailAddress = Trim(varArrayItem)
 71                     If Len(strEmailAddress) > 0 Then
 72                         Set oRecipient = .Recipients.Add(strEmailAddress)
 73                         oRecipient.Type = olTo
 74                         Set oRecipient = Nothing
 75                     End If
 76                 
 77                 Next varArrayItem
 78             
 79             'Create the recipients CC
 80                 TempArray = Split(strCC, ";")
 81                 For Each varArrayItem In TempArray
 82                 
 83                     strEmailAddress = Trim(varArrayItem)
 84                     If Len(strEmailAddress) > 0 Then
 85                         Set oRecipient = .Recipients.Add(strEmailAddress)
 86                         oRecipient.Type = olCC
 87                         Set oRecipient = Nothing
 88                     End If
 89                 
 90                 Next varArrayItem
 91             
 92             'Create the recipients BCC
 93                 TempArray = Split(strBCC, ";")
 94                 For Each varArrayItem In TempArray
 95                 
 96                     strEmailAddress = Trim(varArrayItem)
 97                     If Len(strEmailAddress) > 0 Then
 98                         Set oRecipient = .Recipients.Add(strEmailAddress)
 99                         oRecipient.Type = olBCC
100                         Set oRecipient = Nothing
101                     End If
102                 
103                 Next varArrayItem
104             
105             'Set the message SUBJECT
106                 .Subject = strSubject
107             
108             'Set the message BODY (HTML or plain text)
109                 If StrComp(Left(strMessageBody, 6), "<HTML>", _
110                             vbTextCompare) = 0 Then
111                     .HTMLBody = strMessageBody
112                 Else
113                     .Body = strMessageBody
114                 End If
115 
116             'Add any specified attachments
117                 TempArray = Split(strAttachments, ";")
118                 For Each varArrayItem In TempArray
119                 
120                     strAttachmentPath = Trim(varArrayItem)
121                     If Len(strAttachmentPath) > 0 Then
122                         .Attachments.Add strAttachmentPath
123                     End If
124                 
125                 Next varArrayItem
126 
127             .Send 'The message will remain in the outbox if this fails
128 
129             Set MAPIMailItem = Nothing
130             
131           End With
132 
133         End If
134 
135         Set MAPIFolder = Nothing
136       
137       End If
138 
139       MAPISession.Logoff
140       
141     End If
142     
143     'If we got to here, then we shall assume everything went ok.
144     blnSuccessful = True
145     
146 ExitRoutine:
147     Set MAPISession = Nothing
148     FnSendMailSafe = blnSuccessful
149     
150     Exit Function
151     
152 ErrorHandler:
153     MsgBox "An error has occured in the user defined Outlook VBA function " & _
154             "FnSendMailSafe()" & vbCrLf & vbCrLf & _
155             "Error Number: " & CStr(Err.Number) & vbCrLf & _
156             "Error Description: " & Err.Description, _
157                 vbApplicationModal + vbCritical
158     Resume ExitRoutine
159 
160 End Function

 

-----------附录2-----------

 1 Option Explicit
 2 
 3 ' 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 '
 4 ' Please read the full tutorial & code here:
 5 ' http://www.everythingaccess.com/tutorials.asp?ID=112
 6 '
 7 ' Please leave the copyright notices in place - Thank you.
 8 
 9 ' This is a test function! - replace the e-mail addresses ' with your own before executing!!
10 ' (CC/BCC can be blank strings, attachments string is optional)
11 
12 Sub FnTestSafeSendEmail()
13     Dim blnSuccessful As Boolean
14     Dim strHTML As String
15         
16     strHTML = "<html>" & _
17                "<body>" & _
18                "My <b><i>HTML</i></b> message text!" & _
19                "</body>" & _
20                "</html>" 
21     blnSuccessful = FnSafeSendEmail("myemailaddress@domain.com", _
22                                     "My Message Subject", _
23                                     strHTML)
24     
25     'A more complex example...    
26     'blnSuccessful = FnSafeSendEmail( _
27                         "myemailaddress@domain.com; recipient2@domain.com", _
28                         "My Message Subject", _     
29                         strHTML, _    
30                         "C:\MyAttachFile1.txt; C:\MyAttachFile2.txt", _ 
31                         "cc_recipient@domain.com", _  
32                         "bcc_recipient@domain.com")
33 
34     If blnSuccessful Then
35     
36         MsgBox "E-mail message sent successfully!"
37         
38     Else
39     
40         MsgBox "Failed to send e-mail!"
41     
42     End If
43 
44 End Sub
45 
46 
47 'This is the procedure that calls the exposed Outlook VBA function...
48 Public Function FnSafeSendEmail(strTo As String, _
49                     strSubject As String, _
50                     strMessageBody As String, _
51                     Optional strAttachmentPaths As String, _
52                     Optional strCC As String, _
53                     Optional strBCC As String) As Boolean
54 
55     Dim objOutlook As Object ' Note: Must be late-binding.
56     Dim objNameSpace As Object
57     Dim objExplorer As Object
58     Dim blnSuccessful As Boolean
59     Dim blnNewInstance As Boolean
60     
61     'Is an instance of Outlook already open that we can bind to?
62     On Error Resume Next
63     Set objOutlook = GetObject(, "Outlook.Application")
64     On Error GoTo 0
65     
66     If objOutlook Is Nothing Then
67     
68         'Outlook isn't already running - create a new instance...
69         Set objOutlook = CreateObject("Outlook.Application")
70         blnNewInstance = True    
71         'We need to instantiate the Visual Basic environment... (messy)
72         Set objNameSpace = objOutlook.GetNamespace("MAPI")
73         Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)
74         objExplorer.CommandBars.FindControl(, 1695).Execute
75                 
76         objExplorer.Close
77                 
78         Set objNameSpace = Nothing
79         Set objExplorer = Nothing
80         
81     End If
82 
83     blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _
84                                                 strSubject, strMessageBody, _
85                                                 strAttachmentPaths)
86                                 
87     If blnNewInstance = True Then objOutlook.Quit
88     Set objOutlook = Nothing
89     
90     FnSafeSendEmail = blnSuccessful
91     
92 End Function
posted @ 2012-09-25 00:05  斑苍  阅读(6771)  评论(0)  编辑  收藏  举报