VBA实现outlook自动发信 2

659441806

　　主要的问题：
通过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