Sub SendMail()
 
'要能正确发送并需要对Microseft Outlook进行有效配置
 
On Error Resume Next
 
Dim rowCount, endRowNo
 
Dim objOutlook As Object
 
Dim objMail As Object
 
'取得当前工作表与Cells(1,1)相连的数据区行数
 
'endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
endRowNo = Worksheets("邮箱地址").UsedRange.Rows.Count
 
'创建objOutlook为Outlook应用程序对象
 
Set objOutlook = CreateObject("Outlook.Application")

 
'开始循环发送电子邮件
 
For rowCount = 2 To endRowNo
 
'创建objMail为一个邮件对象
 
Set objMail = objOutlook.CreateItem(olAppointmentItem)

'设置收件人地址（从通讯录表的“E-mail地址”字段中获得）
objMail.From = "energy@gdecc.cn"
 
objMail.To = Worksheets("邮箱地址").Cells(rowCount, 2).Value
 
'设置邮件主题
 
objMail.Subject = Worksheets("邮件内容").Cells(1, 2).Value
 
'设置邮件内容（从通讯录表的“内容”字段中获得）
 
objMail.Body = Worksheets("邮件内容").Cells(2, 2).Value
 
'设置附件（从通讯录表的“附件”字段中获得）
 
'objMail.Attachments.Add Cells(rowCount, 4)
 
'自动发送邮件
 
objMail.Send
 

 
'销毁objMail对象
 
Set objMail = Nothing
 
Next
 
'销毁objOutlook对象
 
Set objOutlook = Nothing
 
'所有电子邮件发送完成时提示
 
MsgBox (rowCount - 2) & "封邮件发送成功！"
 
End Sub