蜂窝日常

两种方式，一种需要本机Outlook配置好的，一种不需要，使用CDO

一、Outlook模式

该模式需要你电脑中有正常使用的Outlook，不是装了软件就可以了，要配置好正常能用

用例

Sub test()
    Set mm = New MailForOutlook
    s = mm.GenerateEmail("gnefnuy@qq.com", "主题：测试", "<b>加粗</b><br>测试", True)
End Sub

复制下面的，新建类模块，粘贴，名称建议命名为MailForOutlook

Option Explicit

Private mMailApp As Object
Private Const APP_NAME As String = "Outlook.Application"

Public Sub GenerateEmail( _
    ByVal ToRecipient As String, _
    ByVal EmailSubject As String, _
    ByVal EmailBody As String, _
    Optional ByVal AutoSend As Boolean, _
    Optional ByVal CCRecipient As String, _
    Optional ByVal BCCRecipient As String _
)
    If mMailApp Is Nothing Then Set mMailApp = CreateObject(APP_NAME)
    With mMailApp
        Dim OutMail As Object: Set OutMail = .CreateItem(0)
        With OutMail
            .To = ToRecipient
            .CC = CCRecipient
            .BCC = BCCRecipient
            .Subject = EmailSubject
            .BodyFormat = 2 'olFormatHTML
            '.Body = EmailBody
            .HTMLBody = EmailBody
            If AutoSend Then
                .Send
            Else
                .Display
            End If
        End With
    End With
End Sub

Public Sub Destroy()
    On Error GoTo ErrorHandler
    If Not mMailApp Is Nothing Then
        mMailApp.Quit
        Set mMailApp = Nothing
    End If

    Exit Sub
ErrorHandler:
    If Err.Number > 0 Then
        Debug.Print _
            "Error Disposing of " & APP_NAME; ":" & vbCrLf _
            & Err.Description
        Err.Clear
        Resume Next
    End If
End Sub

Private Sub Class_Terminate()
    Destroy
End Sub

二、使用CDO模式（不需要Outlook)

用例

Sub test()
    Call CDOSENDEMAIL
End Sub

复制下面的代码，新建模块，建议命名MailForCDO，修改内部相关参数

Sub CDOSENDEMAIL()
    'On Error Resume Next '出错后继续执行
    Application.DisplayAlerts = False '禁用系统提示
    'ThisWorkbook.ChangeFileAccess Mode:=xlReadOnly '将工作簿设置为只读模式
    Set CDOMail = CreateObject("CDO.Message") '创建对象
    CDOMail.From = "XXX@XX.com" '设置发信人的邮箱
    CDOMail.To = "YYY@YY.com" '设置收信人的邮箱
    CDOMail.Subject = "主题:用CDO发送邮件试验" '设定邮件的主题
    CDOMail.TextBody = "文本内容"   '使用文本格式发送邮件似乎不能换行,只能切换成HTML模式换行."
    CDOMail.HtmlBody = "使用html" & "<br>" & "换行后的内容" '使用Html格式发送邮件
    'CDOMail.AddAttachment ThisWorkbook.Path & "\" & "a" & ".xlsx" '发送当前目录下的工作簿a为附件
    stUl = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址    
    With CDOMail.Configuration.Fields
        .Item(stUl & "smtpusessl") = True
        .Item(stUl & "smtpserver") = "smtp.XX.com" 'SMTP服务器地址
        .Item(stUl & "smtpserverport") = 465 'SMTP服务器端口 465 是ssl连接 25是普通连接
        .Item(stUl & "sendusing") = 2 '发送端口
        .Item(stUl & "smtpauthenticate") = 1 '远程服务器需要验证
        .Item(stUl & "sendusername") = "XXX@XX.com" '发送方邮箱名称
        .Item(stUl & "sendpassword") = "XXXXXXXXXXXX" '一般是你自己邮箱生成的授权码，非你邮箱正式密码
        .Item(stUl & "smtpconnectiontimeout") = 60 '连接超时（秒）
        .Update
    End With
    CDOMail.Send '执行发送
    Set CDOMail = Nothing '发送成功后即时释放对象
    'If Err.Number = 0 Then
    'MsgBox "成功发送邮件", , "温馨提示" '如果没有出错，则提示发送成功
    'Else
    'MsgBox Err.Description, vbInformation, "邮件发送失败" '如果出错，则提示错误类型和错误代码
    'End If
    'ThisWorkbook.ChangeFileAccess Mode:=xlReadWrite '将工作簿设置为读写模式
    'Kill ThisWorkbook.Path & "\" & "a" & ".xlsx" '新工作簿删除
    'Call dayin
    Application.DisplayAlerts = True '恢复系统提示
End Sub