邮件群发-不同邮件发不同人(从excel,利用outlook)

(1)可以在excel中维护邮件主题、内容,并将不同附件添加到不同的邮件地址,实现批量对不同的人发送不同的邮件。(2)修订了原程序,可以先将邮件保存到草稿箱,检查后在发送。(3)注：不同附件的生成请另程序编写

Public Function SendMail(strFrom As String, strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strBody As String, _
strFilename As String _
) As Boolean
Dim oOutlookApp As New Outlook.Application
Dim oItemMail As Outlook.MailItem
Set oItemMail = oOutlookApp.CreateItem(olMailItem)

On Error GoTo errHandle
If Len(Trim(strFilename)) = 0 Then
With oItemMail
'.Recipients
.SentOnBehalfOfName = strFrom
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.Body = strBody
'.Attachments.Add (strFilename)
.Importance = olImportanceHigh
.Sensitivity = olPersonal
.Send
End With
Else
With oItemMail
'.Recipients
.SentOnBehalfOfName = strFrom
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.Body = strBody
.Attachments.Add (strFilename)
.Importance = olImportanceHigh
.Sensitivity = olPersonal
.Send
End With
End If

SendMail = True
Exit Function
errHandle:
SendMail = False
End Function


Public Function CheckMail(strFrom As String, strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strBody As String, _
strFilename As String _
) As Boolean
Dim oOutlookApp As New Outlook.Application
Dim oItemMail As Outlook.MailItem
Set oItemMail = oOutlookApp.CreateItem(olMailItem)

On Error GoTo errHandle
If Len(Trim(strFilename)) = 0 Then
With oItemMail
'.Recipients
.SentOnBehal
fOfName = strFrom
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.Body = strBody
'.Attachments.Add (strFilename)
.Importance

(1)可以在excel中维护邮件主题、内容,并将不同附件添加到不同的邮件地址,实现批量对不同的人发送不同的邮件。(2)修订了原程序,可以先将邮件保存到草稿箱,检查后在发送。(3)注：不同附件的生成请另程序编写

= olImportanceHigh
.Sensitivity = olPersonal
' .Display
.Save
End With
Else
With oItemMail
'.Recipients
.SentOnBehalfOfName = strFrom
.To = strTo
.CC = strCC
.BCC = strBCC
.Subject = strSubject
.Body = strBody
.Attachments.Add (strFilename)
.Importance = olImportanceHigh
.Sensitivity = olPersonal
' .Display
.Save
End With
End If

CheckMail = True
Exit Function
errHandle:
CheckMail = False
End Function

Sub SendMailNow()

Dim ExcelSheet As Object
Dim rowCount As Integer
Dim i As Integer

Set ExcelSheet = CreateObject("c:\email.xls")
rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

For i = 2 To rowCount
SendMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
strFilename:=ExcelSheet.sheets(1).cells(i, 7)
Next i
ExcelSheet.Close False
Set ExcelSheet = Nothing

End Sub

Sub CheckMailNow()


aa = Timer

Dim ExcelSheet As Object
Dim rowCount As Integer
Dim i As Integer

Set ExcelSheet = CreateObject("c:\email.xls")
rowCount = ExcelSheet.sheets(1).UsedRange.Rows.Count

For i = 2 To rowCount
CheckMail strFrom:=ExcelSheet.sheets(1).cells(i, 1), strTo:=ExcelSheet.sheets(1).cells(i, 2), _
strCC:=ExcelSheet.sheets(1).cells(i, 3), strBCC:=ExcelSheet.sheets(1).cells(i, 4), _
strSubject:=ExcelSheet.sheets(1).cells(i, 5), strBody:=ExcelSheet.sheets(1).cells(i, 6), _
strFilename:=ExcelSheet.sheets(1).cells(i, 7)

Next i
ExcelSheet.Close F
alse
Set ExcelSheet = Nothing

MsgBox "Total Time := " & Format(Timer - aa, "0.00") & "s"


End Sub