Excel VBA开发自动发送邮件
2017-04-27 17:37
351 查看
一、.设置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,写如下代码:
4.2 创建自动发送邮件界面,方便用户可以看到操作Excel表格哪一行。
主要代码如下:
Excel表格中的内容如下
二、.设置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 = "<html>" & _ "<head>" & _ "<meta http-equiv=""Content-Type"" contentType=""application/vnd.ms-excel;charset=gb2312"">" & _ " <STYLE type=text/css>" & _ " .sub_title{" & _ " FONT-WEIGHT: bold;" & _ " FONT-SIZE: 4mm;" & _ " VERTICAL-ALIGN: middle;" & _ " TEXT-ALIGN: center" & _ " background-color: #ffff66//" & _ " }" htmlBody = htmlBody & " .context {" & _ " font-size: 12px;" & _ " BORDER-TOP-WIDTH: 0.6mm;" & _ " PADDING-RIGHT: 1mm;" & _ " PADDING-LEFT: 1mm;" & _ " BORDER-LEFT-WIDTH: 0.6mm;" & _ " BORDER-BOTTOM-WIDTH: 0.6mm;" & _ " PADDING-BOTTOM: 0mm;" & _ " PADDING-TOP: 0mm;" & _ " BORDER-COLLAPSE: collapse;" & _ " BORDER-RIGHT-WIDTH: 0.6mm" & _ " }" htmlBody = htmlBody & " .context td{" & _ " border:1px solid #009900;" & _ " }" & _ " .page {" & _ " page-break-after: always;" & _ " }" & _ " </STYLE>" & _ "</head><body>Dear " & EmpName & Chr(13) htmlBody = htmlBody & "<table class=""context"" borderColor=""#669933"" border=1>" 'MsgBox htmlBody '表头 tableHeader = "<tr bgcolor=""#FFE66F""><td align=""center"">固定工<br>资基准</td>" & _ "<td align=""center"">浮动绩<br>效基准</td><td align=""center"">应勤<br>时数</td>" & _ "<td align=""right"">实际<br>出勤</td><td align=""center"">节<br>假日</td><td align=""center"">考核<br>系数</td>" & _ "<td align=""center"">固定<br>工资</td><td align=""center"">浮动<br>绩效</td><td align=""center"">外宿<br>补贴</td>" & _ "<td align=""right"">伙食&补贴</td><td align=""center"">奖金</td><td align=""center"">提成</td>" & _ "<td align=""right"">补贴</td><td align=""center"">补发</td><td align=""center"">其他<br>补贴</td>" & _ "<td align=""right"">应发<br>合计</td><td align=""center"">迟到</td><td align=""center"">伙食</td>" & _ "<td align=""right"">社保</td><td align=""center"">公<br>积金</td><td align=""center"">房租</td>" & _ "<td align=""right"">水电</td><td align=""center"">个税</td><td align=""center"">话费</td>" & _ "<td align=""right"">代扣学费</td><td align=""center"">其他</td><td align=""center"">代扣<br>合计</td>" & _ "<td align=""right"">实发工资</td></tr>" 'MsgBox Worksheets("Sheet1").Range("F" & i).Value '表格内容 tableBody = "<tr>" & _ "<td>" & Worksheets("Sheet1").Range("F" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("G" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("H" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("I" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("J" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("K" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("L" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("M" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("N" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("O" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("P" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("Q" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("R" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("S" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("T" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("U" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("V" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("W" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("X" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("Y" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("Z" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AA" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AB" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AC" & Row).Value & "</td>" tableBody = tableBody & "<td>" & Worksheets("Sheet1").Range("AD" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AE" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AF" & Row).Value & "</td>" & _ "<td>" & Worksheets("Sheet1").Range("AG" & Row).Value & "</td>" & _ "</tr>" 'MsgBox tableBody htmlBody = htmlBody & tableHeader & tableBody & "</table></body></html>" SalaryContext = htmlBody End Function
Excel表格中的内容如下
相关文章推荐
- 通用邮件自动发送Winform控件开发(四)
- Excel VBA开发自动发送邮件
- 通用邮件自动发送Winform控件开发(五)
- UFT开发实例:QTP调用OutLook自动发送邮件
- 通用邮件自动发送Winform控件开发(二)
- 自动发送邮件程序开发
- 通用邮件自动发送Winform控件开发(六)
- 通用邮件自动发送Winform控件开发(一)
- 通用邮件自动发送Winform控件开发(三)
- 如何配置Subversion自动发送邮件
- TD邮件自动发送配置步骤
- JavaBean邮件自动发送程序带附件
- VC中自动发送邮件的实现
- VC中自动发送邮件的实现
- 一个简单的自动发送邮件系统(一)
- 用java开发Email工具之发送邮件 (1)作者:冯睿
- mutt+msmtp轻松实现邮件自动发送功能
- 使用Jmail自动发送邮件
- 基于BCB开发具有身份认证功能的邮件发送程序
- 一个简单的自动发送邮件系统(一)