通过EXCEL自动发送邮件

原创

iamcfan 2009-12-25 21:54:16 ©著作权

©著作权归作者所有：来自51CTO博客作者iamcfan的原创作品，请联系作者获取转载授权，否则将追究法律责任

编程对于我来说是很困难的一件事，做网络管理一年多，最多是弄一些简单的批处理和一些简单的智能脚本之类的东西。

前段时间接到一个任务，给公司400百多号项目上的人员发邮件，一人发一封关于公司×××资料相关的信息，听完之后人都快疯掉，这么多的人得发到什么时候才是个头。终于想到了一个偷懒的办法，用EXCEL里面的宏来给他们发。GOOGLE BAIDU里面快翻了个遍，找来一段代码，研究了好几个小时才弄明白怎么用。下面是VB代码：

自动发送邮件() 自动发送邮件()

'

'要能正确发送并需要对Microseft Outlook进行有效配置

On Error Resume Next

Dim rowCount, endRowNo

'要正常运行下面这句,要将工具/引用中的Microseft Outlook *.0 Object Library(其中*为你Microseft Outlook的版本号)选上

Dim objOutlook As New Outlook.Application

Dim objMail As MailItem

'取得当前工作表与Cells(1,1)相连的数据区行数

endRowNo = Cells(1, 1).CurrentRegion.Rows.Count

'创建objOutlook为Outlook应用程序对象

Set objOutlook = New Outlook.Application

'开始循环发送电子邮件

For rowCount = 2 To endRowNo

'创建objMail为一个邮件对象

Set objMail = objOutlook.CreateItem(olMailItem)

With objMail

'设置收件人地址（从通讯录表的'E-mail地址'字段中获得）

.To = Cells(rowCount, 1)

'设置邮件主题

.Subject = Cells(rowCount, 2)

'设置邮件内容（从通讯录表的'内容'字段中获得）

.Body = Cells(rowCount, 3) + Chr(10) + Chr(10)

'设置附件（从通讯录表的'附件'字段中获得）
.Attachments.Add Cells(rowCount, 4).Value, , 1, ""

'显示窗口
.Display

End With

On Error GoTo continue

SendEmail:


         AppActivate objMail


         DoEvents

         SendKeys "%s", Wait:=False
        DoEvents
        objMail.Display

GoTo SendEmail

continue:

     On Error GoTo 0

'        Set bjOutlook = Nothing

        Set objMail = Nothing

Next

'销毁objOutlook对象

Set objOutlook = Nothing

'所有电子邮件发送完成时提示

'MsgBox rowCount - 1 & "个朋友的问候信发送成功！"

'

        If Application.Workbooks.Count = 1 Then

        Application.Quit

        Else

        Workbooks("自动发邮件.xls").Close

        End If

'

End Sub

花了一天时间，到最后N次出现这样的结果，人都快崩溃了，后面还找了个搞软件的朋友帮忙修改，最后的结果是，每次只能自动发送两个人，后面的几百个就不发通过EXCEL自动发送邮件_宏