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
页:
[1]