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
### 如何在 Outlook 中设置和使用电子签名 #### 创建新的电子邮件签名 为了创建一个新的电子邮件签名,在 Outlook 的菜单栏中选择【文件】选项卡,接着点击左侧的“签名”按钮[^1]。此时会弹出一个窗口允许用户编辑不同类型的签名。 对于 HTML 邮件,默认情况下可以选择字体样式、颜色和其他格式化选项来定制签名外观;而对于纯文本邮件,则仅限于简单的文字输入[^4]。 #### 设置默认签名 在同一界面内可指定哪一版签名为特定账户发送的新消息或是回复与转发旧有对话时所使用的默认版本。如果希望每次发信自动附带相同的内容,这项功能非常有用。 #### 备份及恢复个人化的署名档 当需要迁移电脑或者担心数据丢失时,应该考虑定期备份自己的个性化邮箱结尾语句。具体做法是找到存储路径 `C:\Users\%username%\AppData\Roaming\Microsoft\Signatures` 并复制整个文件夹到安全的地方存储备份副本。要重新应用已保存过的配置只需反向操作——把之前保留下来的资料放回到上述提到的位置即可[^2]。 #### 使用 VBA 自动化处理含签名的电邮 通过编写一段 Visual Basic for Applications (VBA) 脚本可以在 Excel 或其他 Office 应用程序里实现自动化发送带有预设好格式和个人信息备注在内的官方通知等功能。下面给出了一段示范性的代码片段用于展示怎样调用现有的图形化界面之外的方法完成此任务: ```vba Sub SendEmailWithSignature() Dim olApp As Object Set olApp = CreateObject("Outlook.Application") ' 创建新邮件项 Dim mailItem As Object Set mailItem = olApp.CreateItem(0) With mailItem .To = "example@example.com" .Subject = "Test Email with Signature" ' 插入正文内容并附加HTML形式的签名 .BodyFormat = 2 ' olFormatHTML .HTMLBody = "<p>This is a test message.</p>" & GetDefaultSignature(.Parent) '.Send ' 发送前请先取消注释这行 .Display ' 显示草稿箱中的邮件以便查看效果 End With End Sub Function GetDefaultSignature(parentFolder As Object) As String On Error Resume Next GetDefaultSignature = parentFolder.Session.GetDefaultFolder(9).Folders.Item("Signatures").Items.Item("New Messages.htm").GetContent End Function ``` 这段脚本展示了如何利用 VBA 来构建一封包含自定义签名的新邮件,并且提供了获取默认签名内容的方式。注意实际部署时可能还需要调整某些细节以适应具体的环境需求[^3]。
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值