利用Outlook发邮件

2017-07-21 10:10:00
zstmtony
原创
1827
论坛里已经有不少这方面的例子了,有用CDO的也有用Outlook组件的。不过个人偏向于用Outlook。
我对Outlook其实并不熟悉,内置的对象基本都是现学现卖的。不过既然有朋友问到,那就写写,算是整合一下吧。

在使用Outlook发邮件之前,必须要先设置好收件和发件服务器。下面,就以网易的yeah.net为例,跟我先设置好吧。一般情况下,登录邮箱网站后,可以在“设置”或者“帮助”(例如,搜狐闪电邮)里找到pop3服务器和SMTP服务器地址:


 
然后打开Outlook。如果是第一次打开,按向导一步步来就好了。如果已经设置了一个账号,则可以在“文件/信息/添加账号”里自行添加:
 
个人不太赞成自动添加。毕竟,自动添加时机器识别还不如手动录入准确。然后选择POP3(如果是公司内部架设邮箱服务器的话,应该是Exchange,这里就不深究了):
 
然后就是填上这些信息了。需要注意的是,姓名是希望显示的名字(例如:不明真相的吃瓜吃饼喝水吃面群众),最下面的用户名是登录邮箱的用户名。填入前面在网站上看到的POP3和SMTP服务器地址:
 
需要注意的是,大多数邮箱发送时可能都需要验证,因此还需要在“其它设置”里勾选(如果不勾选的话,只能收邮件而不能发邮件):
 
-------------------------------------------------------------

至此,设置结束。接下来就是写代码完成发送的过程了:


Function SendMailToAll(ByVal strSubject As String, ByVal strBody As String, Optional ByVal blnAttachment As Boolean = False)
    '定义Outlook组件
    Dim appOutlook As New Outlook.Application
    Dim objMailItem As Outlook.MailItem
    
    '定义记录集,用于读取邮箱列表
    Dim rst As New ADODB.Recordset
    Dim strMailAddress As String
    
    '定义文件拾取器,用于添加多个附件。
    Dim fd As FileDialog
    Dim i As Long
    
    Set objMailItem = appOutlook.CreateItem(olMailItem)
    
    With objMailItem
    
        '打开邮箱列表并在读取完毕后关闭邮箱列表
        rst.Open "tblMailingList", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
            Do Until rst.EOF
                strMailAddress = strMailAddress & rst(1) & ";"
                rst.MoveNext
            Loop
        .To = strMailAddress
        rst.Close
        Set rst = Nothing
        
        '设置主题和主体,如需格式化文本,请使用HTMLBody属性,并编写HTML代码:
        .Subject = strSubject
        .Body = strBody
        
        '.HTMLBody = "<P style=""color:red;font-size:14px;font-weight:700"">" & strBody & "</p>"
        
        '是否上传附件。如需上传,则打开文件拾取器。
        If blnAttachment Then
            If MsgBox("您已经选择了上传附件,为了便于一次上传多个附件,请务必确保所有附件都在同一个文件夹内。", vbYesNoCancel) = vbYes Then
                Set fd = Application.FileDialog(msoFileDialogFilePicker)
                fd.AllowMultiSelect = True
                If fd.SHOW = -1 Then
                    For i = 1 To fd.SelectedItems.Count
                        .Attachments.Add fd.SelectedItems(i), olByValue, , Mid(fd.SelectedItems(i), InStrRev(fd.SelectedItems(i), "") + 1, Len(fd.SelectedItems(i)))
                    Next
                End If
            End If
        End If
        
        .Send
    End With
End Function
大部分注释已经有了,就不再一一解释代码了。需要引用Outlook库、Office库和ActiveX Data Object库。运行代码前请确认这一点。
其它:
由于Outlook的安全机制问题,发送时会弹出安全警告,等几秒后点击“允许”即可。网上有说安装VS的Outlook安全管理器插件可以解决这个问题。但个人觉得没必要。特别是分发给用户使用时,是不是每个用户都帮ta安装?
分享