Excel批量发送电子工资条

时　间:2011-10-09 11:47:07
作　者:欢乐小爪   ID：20149  城市：杭州
摘　要:Excel批量发送电子工资条
正　文:

新建模块1: 复制以下代码

Sub AutoMail()
On Error Resume Next
Dim rowCount As Long, colCount As Long, endRowNo As Long, r As Range
Dim arr()
Dim strdata As String, strtop As String
'Dim objOutlook As New Outlook.Application
'Set objOutlook = New Outlook.Application
'Dim objMail As MailItem
Set objOutlook = CreateObject("Outlook.Application")
'选定需发送的数据区域，第一行应为标题，第一列应为邮箱地址，最后一列为备注。
Set r = Selection
endRowNo = r.Rows.Count '取得需发送的数据区域行数和列数
colCount = r.Columns.Count - 1
ReDim arr(1 To 1, 2 To colCount) '根据选定的列数重新定义数组
arr = WorksheetFunction.Transpose(Range(r.Cells(1, 2), r.Cells(1, colCount))) '获取标题行
strtop = Join(WorksheetFunction.Transpose(arr), "</td><td>")
Erase arr '清空数组变量
For rowCount = 2 To endRowNo '获取数据行
arr = WorksheetFunction.Transpose(Range(r.Cells(rowCount, 2), r.Cells(rowCount, colCount)))
strdata = Join(WorksheetFunction.Transpose(arr), "</td><td>")
Set objMail = objOutlook.CreateItem(olMailItem)
With objMail
.To = Cells(rowCount, 1) '邮件接收人等于本行的第一列
.Subject = ActiveSheet.Name '邮件标题等于工作表的表名
'.Body = strtop & vbCrLf & s
.HTMLBody = "<table border=""1"" cellpadding=""2""><tr><td>" & strtop & "</td></tr>" & "<tr><td>" & strdata & "</td></tr></table>" & _
"<br><br><span style='font-size:14.0pt;font-family:楷体'> " & r.Cells(rowCount, colCount + 1) & "</span>"
'.Attachments.Add Cells(rowCount, 5)
'让outlook不显示提示
.Sensitivity = olPersonal
.Send
End With
Set objMail = Nothing
Erase arr
Next
Set objOutlook = Nothing
End Sub

新建模块2: 复制以下代码

Public XLCommandBar As String
Public XLMenu As String
Public XLMenuItem As String
Public NewMenuItem As String
Public NewMenuItemMacro As String
Private Sub Auto_Open()
' 给变量赋值
XLCommandBar = "Worksheet Menu Bar"
XLMenu = "工具(T)"
XLMenuItem = ""
NewMenuItem = "AutoMail"
NewMenuItemMacro = "OpenRobot"
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim NewItem As CommandBarButton
' 删除当前菜单如果它存在（以防万一）
On Error Resume Next
Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls(XLMenuItem).Controls(NewMenuItem).Delete
Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls(NewMenuItem).Delete
On Error GoTo 0
'创建新的菜单项目
If XLMenuItem = "" Then
Set NewItem = Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls.Add
Else
Set NewItem = Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls(XLMenuItem).Controls.Add
End If

' 指定标题和运行宏名
With NewItem
.Caption = NewMenuItem
.OnAction = NewMenuItemMacro ' 这个过程在模块1中
.FaceId = 0 ' 按钮图符显示菜单项目文本
.BeginGroup = True '增加一个隔离条在菜单项目前
End With
Exit Sub

' 如果发生错误，告诉使用者
If Err <> 0 Then
MsgBox "An error occurred.", vbInformation
End If
End Sub
Sub Auto_Close()
' 在关闭工作薄或加载宏时执行此过程
' 它简单地移除菜单项目
On Error Resume Next
Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls(XLMenuItem).Controls(NewMenuItem).Delete
Application.CommandBars(XLCommandBar).Controls(XLMenu).Controls(NewMenuItem).Delete
End Sub
Private Sub OpenRobot()
Call AutoMail
End Sub

使用方法:
选定需发送的单元格区域，其中第一行为标题，第一列为邮箱地址，最后一列为备注。
Office2003可以在菜单－工具下找到AutoMail，点击即会进行自动批量发送。
Office2007－2010可以在加载项里找到AutoMail，点击即会进行自动批量发送。