代码如下
Sub send()
On Error Resume Next
Dim rowCount, endRowNo, endColumnNo, sFile$, sFile1$, A&, B&
Dim objOutlook As Object
'Dim objMail As MailItem
'取得当前工作表格的行数和列数以
endRowNo = ActiveSheet.UsedRange.Rows.Count
endColumnNo = ActiveSheet.UsedRange.Columns.Count
'获取当前sheet的名称
Sheet = ActiveSheet.Name
'调用Outlook客户端邮箱
Set myOlApp = CreateObject("Outlook.Application")
'循环所有行
For rowCount = 2 To endRowNo
'新建一封邮件
Set objMail = myOlApp.CreateItem(olMailItem)
'正文显示
sFile = " <tr>您好!<br> 以下是您" + Sheet + ",请查收!</tr><table border=0 style='border-right: 1px solid #a8aeb2;border-bottom: 1px solid #a8aeb2;'> "
For A = 1 To endColumnNo
'含有字母大写X的列不发送,先把表头打印,在把对应员工的一行保存在变量里,构造了一个简单html的表格。
If Application.WorksheetFunction.CountIf(Cells(1, A), "*X*") = 0 Then
sFile = sFile + " <tr><td width='150' height='25' style='border-top: 1px solid #a8aeb2;border-left: 1px solid #a8aeb2;padding: 3px 7px;'> " + Cells(1, A).Text + " </td> <td width='230' height='25' style='border-top: 1px solid #a8aeb2;border-left: 1px solid #a8aeb2;padding: 3px 7px;'> " + Cells(rowCount, A).Text + "</td></tr> "
End If
Next
sFile = sFile + "</table>"
With objMail
'收件人,在第二列了,如果放到其它列可以修改这里的2数字
.To = Cells(rowCount, 2)
'邮件标题
.Subject = Sheet
'//正文具体内容
.HTMLBody = sFile
'.HTMLBody =RangetoHTML(单元格对象) '//RangetoHTML是自定义函数,见下面。
.Display '//刷新显示效果的作用
.send '//发送
End With
Next
Set objMail = Nothing
MsgBox rowCount - 2 & "个员工的工资单发送成功!"
End Sub