Excel VBA开发自动发送邮件

一、.设置Outlook邮箱帐(略不是本文章的重点)

二、.设置Outlook信任中心如下步骤

        若没有做如下操作设置，则Excel VBA调用Outlook自动发送邮件时提示如下

2.1 Outlook->工具->信任中心

2.2 编程访问->选中”从不向我发出可疑活动警告(不推荐)“，注意:建议使用Excel VBA自动发送邮件启用该功能

三、启用Excel 宏

 

3.1 启用宏操作如下:

打开Excel点击Office按钮->Excel选项，如下图

选择”Excel 选项“窗体中左边的”信任中心“->信任中心设置，如下图:

在”信任中心“窗体中->宏设置，选如下图二个选项

然后关闭Excel重新打开就可以启用宏和VBA编程开发了。

四、Excel VBA开发

 

4.1 创建模类:clsModel,写如下代码:

Public Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub AutoMail()
    GB_EMPSALARY.Show
End Sub

'Function WinProcA(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
'    KillTimer 0, idEvent
'    DoEvents
'    Sleep 100
'    '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了
'    Application.SendKeys "%s"
'End Function

' 发送单个邮件的子程序
Sub SendMail(ByVal to_who As String, ByVal SubJect As String, ByVal body As String, ByVal cell As String)
    Dim objOL As Object
    Dim itmNewMail As Object
    '引用Microsoft Outlook 对象
    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    On Error GoTo Err_Handle
    
    With itmNewMail
        .SubJect = SubJect  '主旨
        .htmlBody = body    '正文本文
        '.body = body   '正文本文
        .To = to_who  '收件者
        '.Attachments.Add attachement '附件，如果你不需要发送附件，可以把这一句删掉即可，Excel中的第四列留空，不能删哦
        .Display  '启动Outlook发送窗口
        'SetTimer 0, 0, 0, AddressOf WinProcA
        .Send
        'Application.Wait (Now + TimeValue("0:00:03"))
        'Application.SendKeys "%s"
    End With
    Worksheets("Sheet1").Range(cell).Value = "Y"
    Set objOL = Nothing
    Set itmNewMail = Nothing
Err_Handle:
    Set objOL = Nothing
    Set itmNewMail = Nothing
    On Error Resume Next
End Sub

4.2 创建自动发送邮件界面，方便用户可以看到操作Excel表格哪一行。

主要代码如下:

 

Private Sub butSend_Click()
    On Error Resume Next
    Dim i As Integer
    
    Dim EmpName, eMail, mailSubJect, mailBody, cell, sendFlag As String
    
    
    i = CInt(txtStartRow.Text)
    If (i < 3) Then
        i = 3
    End If
    '邮箱主题
        mailSubJect = "某某公司" & Worksheets("Sheet1").Range("C1").Value & "工资条"
    '员工姓名
    EmpName = Worksheets("Sheet1").Range("E" & i).Value
    '员工姓名为空退出停止发送邮件
    Do While EmpName <> ""
        '是否发送邮件标志位
        sendFlag = Worksheets("Sheet1").Range("A" & i).Value
        '邮箱地址
        eMail = Worksheets("Sheet1").Range("AH" & i).Value
        '邮件是否发关，邮箱地址是否为空
        If (sendFlag <> "Y" And eMail <> "") Then
           '邮箱内容
           mailBody = SalaryContext(EmpName, i)
           '是否发送标志单元格
           cell = "A" & i
           SendMail eMail, mailSubJect, mailBody, cell
        End If
        i = i + 1
        '获得下一行的员工姓名
        EmpName = Worksheets("Sheet1").Range("E" & i).Value
        DoEvents
        Sleep 300
        txtSend.Text = i
    Loop
End Sub
'工资条表格明细
Function SalaryContext(ByVal EmpName As String, ByVal Row As Integer) As String
    Dim htmlBody, tableHeader, tableBody As String
    htmlBody = "" & _
        "" & _
        "" & _
        "   " & _
        "Dear " & EmpName & Chr(13)
    
    htmlBody = htmlBody & ""
    'MsgBox htmlBody
    '表头
    tableHeader = "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        ""
   'MsgBox Worksheets("Sheet1").Range("F" & i).Value
   '表格内容
   tableBody = "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        "" & _
        ""

   tableBody = tableBody & "" & _
        "" & _
        "" & _
        "" & _
        ""

   'MsgBox tableBody
    
   htmlBody = htmlBody & tableHeader & tableBody & "
固定工
资基准
浮动绩
效基准
应勤
时数
实际
出勤
节
假日
考核
系数
固定
工资
浮动
绩效
外宿
补贴
伙食&补贴
奖金
提成
补贴
补发
其他
补贴
应发
合计
迟到
伙食
社保
公
积金
房租
水电
个税
话费
代扣学费
其他
代扣
合计
实发工资
" & Worksheets("Sheet1").Range("F" & Row).Value & "
" & Worksheets("Sheet1").Range("G" & Row).Value & "
" & Worksheets("Sheet1").Range("H" & Row).Value & "
" & Worksheets("Sheet1").Range("I" & Row).Value & "
" & Worksheets("Sheet1").Range("J" & Row).Value & "
" & Worksheets("Sheet1").Range("K" & Row).Value & "
" & Worksheets("Sheet1").Range("L" & Row).Value & "
" & Worksheets("Sheet1").Range("M" & Row).Value & "
" & Worksheets("Sheet1").Range("N" & Row).Value & "
" & Worksheets("Sheet1").Range("O" & Row).Value & "
" & Worksheets("Sheet1").Range("P" & Row).Value & "
" & Worksheets("Sheet1").Range("Q" & Row).Value & "
" & Worksheets("Sheet1").Range("R" & Row).Value & "
" & Worksheets("Sheet1").Range("S" & Row).Value & "
" & Worksheets("Sheet1").Range("T" & Row).Value & "
" & Worksheets("Sheet1").Range("U" & Row).Value & "
" & Worksheets("Sheet1").Range("V" & Row).Value & "
" & Worksheets("Sheet1").Range("W" & Row).Value & "
" & Worksheets("Sheet1").Range("X" & Row).Value & "
" & Worksheets("Sheet1").Range("Y" & Row).Value & "
" & Worksheets("Sheet1").Range("Z" & Row).Value & "
" & Worksheets("Sheet1").Range("AA" & Row).Value & "
" & Worksheets("Sheet1").Range("AB" & Row).Value & "
" & Worksheets("Sheet1").Range("AC" & Row).Value & "
" & Worksheets("Sheet1").Range("AD" & Row).Value & "
" & Worksheets("Sheet1").Range("AE" & Row).Value & "
" & Worksheets("Sheet1").Range("AF" & Row).Value & "
" & Worksheets("Sheet1").Range("AG" & Row).Value & "
"
   
   SalaryContext = htmlBody
End Function

Excel表格中的内容如下