利用Outlook和Excel批量发送邮件-1

由于工作需要，而又不能麻烦IT部为这种小程序操劳，我就过把写程序的瘾了。四五年没写过（VB，VBA）Visual Basic Application的程序了，刚开始一两天还真找不到感觉。废话少说，进入正题。

适用范围：批量发送邮件，但苦于没有email server或者不方便利用web server（IIS，weblogic，tomcat）这些服务平台的时候。

运行环境：

Microsoft Windows XP Professional version2002 Service Pack 2，

Microsoft Office Outlook 2003，Excel2003

步骤：

一、建立联系人列表

建立个简单的联系人列表（No，email，name）如下图格式的联系表。工作表名：Sheet1，文件名：book1.xls,将该文件保存至C盘根目录下。

二、在outlook中编写VBA程序

2.1打开OutLook 2003，邮箱帐户（pop3，smtp）设置这里假如已经OK。在outlook 工具->宏->Visual Basic编辑器打开VB编辑器。

2.2在Project1下新建模块新建以下过程或function

'2.2.1 create sub Application_startup()
'这里连接到Excel并读取Sheet1中的联系人信息。
'查询字段的方法还有很多，详细参阅msdn
Private Sub Application_Startup()

    'IGNORE - This forces the VBA project to open and be accessible using automation
    '         at any point after startup

    'Call getRecipients
    Dim mailSubject As String
    Dim cn As New ADODB.Connection
    Dim rsC As ADODB.Recordset
    Dim intColCnt As Integer
    Dim c As Integer, iNo As Integer
    Dim strEmail As String
    Dim strName As String
    Dim body As String
    strEmail = ""
    Set cn = New ADODB.Connection
    With cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Data Source=C:\Book1.xls;Extended Properties=Excel 8.0;"
        .CursorLocation = adUseClient
        .Open
    End With
    Set rsC = New ADODB.Recordset
    rsC.Open "Select * from [Sheet1$]", cn, adOpenStatic
    'rsc.open "Select * from [Sheet1$]"
    intColCnt = rsC.RecordCount
    For c = 1 To intColCnt
        iNo = rsC.Fields(0).Value
        strEmail = rsC.Fields(1).Value
        strName = rsC.Fields(2).Value
        mailSubject = strName & ",您好!这是逗你玩的程序。"
        Call FnSendMailSafe(strEmail, "", "", mailSubject, getMailBody(strName))
        rsC.MoveNext
    Next
    rsC.Close
    cn.Close
End Sub

' 2.2.2 create FnSendMailSafe()
' --------------
' Simply sends an e-mail using Outlook/Simple MAPI.
' Calling this function by Automation will prevent the warnings
' 'A program is trying to send a mesage on your behalf...'
' Also features optional HTML message body and attachments by file path.
'
' The To/CC/BCC/Attachments function parameters can contain multiple items by seperating
' them by a semicolon. (e.g. for the strTo parameter, 'test@test.com; test2@test.com' is
' acceptable for sending to multiple recipients.
'
' Read more here:
' http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-without-Security-Warning
'
Public Function FnSendMailSafe(strTo As String, _
                                strCC As String, _
                                strBCC As String, _
                                strSubject As String, _
                                strMessageBody As String, _
                                Optional strAttachments As String) As Boolean

' (c) 2005 Wayne Phillips - Written 07/05/2005
' http://www.everythingaccess.com
' You are free to use this code within your application(s)
' as long as the copyright notice and this message remains intact.
On Error GoTo ErrorHandler:
    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient
    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim blnSuccessful As Boolean
   
    'Get the MAPI NameSpace object
    'Set objOutlook = CreateObject("Outlook.Application")
    'Set objMail = objOutlook.CreateItem(olMailItem)
    'Set MAPISession = objOutlook.CreateNamespace(MAPISession)
   
    Set MAPISession = Application.Session
    If Not MAPISession Is Nothing Then
     'Logon to the MAPI session
     MAPISession.Logon , , True, False
     'Create a pointer to the Outbox folder
     Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
     If Not MAPIFolder Is Nothing Then
        'Create a new mail item in the "Outbox" folder
        Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
        If Not MAPIMailItem Is Nothing Then
         With MAPIMailItem
            'Create the recipients TO
                TempArray = Split(strTo, ";")
                For Each varArrayItem In TempArray
                    Set oRecipient = .Recipients.Add(CStr(Trim(varArrayItem)))
                    oRecipient.Type = olTo
                    Set oRecipient = Nothing
                Next varArrayItem
            'Create the recipients CC
                TempArray = Split(strCC, ";")
                For Each varArrayItem In TempArray
                    Set oRecipient = .Recipients.Add(CStr(Trim(varArrayItem)))
                    oRecipient.Type = olCC
                    Set oRecipient = Nothing
                Next varArrayItem
            'Create the recipients BCC
                TempArray = Split(strBCC, ";")
                For Each varArrayItem In TempArray
                    Set oRecipient = .Recipients.Add(CStr(Trim(varArrayItem)))
                    oRecipient.Type = olBCC
                    Set oRecipient = Nothing
                Next varArrayItem
            'Set the message SUBJECT
                .Subject = strSubject
            'Set the message BODY (HTML or plain text)
                .BodyFormat = olFormatHTML
                .htmlBody = strMessageBody
            'Add any specified attachments
                TempArray = Split(strAttachments, ";")
                For Each varArrayItem In TempArray
                    .Attachments.Add CStr(Trim(varArrayItem))
                Next varArrayItem
            'No return value since the message will remain in the outbox if it fails to send
            .Send
            Set MAPIMailItem = Nothing
         End With
        End If
        Set MAPIFolder = Nothing
     End If
     MAPISession.Logoff
    End If
    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True
ExitRoutine:
    Set MAPISession = Nothing
    FnSendMailSafe = blnSuccessful
    Exit Function

ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, vbApplicationModal + vbCritical
    Resume ExitRoutine
End Function

'2.2.3创建邮件主体
Function getMailBody(strName As String) As String
    Dim mailBody, htmlBody As String
    htmlBody = mailBody1 & strName & mailBody
    getMailBody = htmlBody
End Function

2.3代码调试的时候可能会出现错误，久了不用VBA你一定忘记还要引用某些东东才可以通过。

2.3 运行Application_Startup(),这里可能会出现如下提示：

激活方法如下：在outlook 工具->宏->安全性修改outlook安全性级别至中或低。

注意事项：

1.该程序没有判断email address是否有效，若出现无效的邮件地址会提示错误。解决方法：增加错误处理机制代码

2.Excel 中三个字段均不允许为空，解决方法：增加判断空或默认一值。

3.不可循环一个excel 中的多个sheet，可根据需要加for循环

4.不可循环多个excel，解决方法同上

5.如果一个Sheet中的数据量太大，过万条数据的话，那么你得准备个像样的机器，要足够的带宽，比较强的mail server耗费几个小时。这里可增加分批执行的代码。

6.要想邮件内容丰富，maibody中可根据需要编写html代码。