宏代码如下：
Sub Button2_Click()
Dim ea As Variant
Dim detail As Variant
Dim Name, Email As String
ea = Sheets("Email Address").[A1].CurrentRegion
de = Sheets("Payment Request").[A1].CurrentRegion
Dim OutlookApp As Outlook.Application
Dim OutlookItem As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Set OutlookItem = OutlookApp.CreateItem(olMailItem)
Dim acc, amm
Dim i&, j&, k&, m&, success, error
acc = Sheets("Email Address").Range("A1").CurrentRegion
amm = Sheets("Payment Request").Range("A1").CurrentRegion
success = 0
error = 0
ReDim bcc(1 To UBound(acc, 1), 1 To UBound(acc, 2))
For i = 2 To UBound(acc)
Name = acc(i, 1)
Email = acc(i, 2)
k = 0
m = 0
j = 1
For j = 1 To UBound(amm)
If amm(j, 1) = Name Then
If k = 0 Then
k = j
m = j
Else
m = j
End If
End If
Next
'outlook 发送邮件
If k <> 0 And m <> 0 Then
' On Error GoTo SendEmail_Error
With OutlookItem
.To = Email
.Subject = Name & " 付款申请已支付通知"
.HTMLBody = RangetoHTML(Sheets("Travel report application").Range("A1:E1")) & _
RangetoHTML(Sheets("Travel report application").Range("A" & k & ":E" & m)) & "<br><br>" & _
"Your payment request above is wiring today, please check your account in time. " & _
"<br><br>" & "(以上付款申请今天已支付，请通知收款方及时查账。）" & _
"<br><br>" & "XXXX." & _
"<br><br>" & "XXXX。"
.Send
End With
SendEmail_Exit:
success = success + 1
Set OutlookItem = Nothing
Set OutlookItem = OutlookApp.CreateItem(olMailItem)
GoTo Continue
SendEmail_Error:
error = error + 1
' MsgBox Err.Description
'Resume SendEmail_Exit
' Exit Sub
' MsgBox ("Name = " & Name & "Email = " & Email & " j = " & j & " k = " & k & " m = " & m)
Continue:
k = 0
m = 0
End If
Next
MsgBox ("成功发送邮件" & success & " ; 失败" & error)
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub Button2_Click()
Dim ea As Variant
Dim detail As Variant
Dim Name, Email As String
ea = Sheets("Email Address").[A1].CurrentRegion
de = Sheets("Payment Request").[A1].CurrentRegion
Dim OutlookApp As Outlook.Application
Dim OutlookItem As Outlook.MailItem
Set OutlookApp = New Outlook.Application
Set OutlookItem = OutlookApp.CreateItem(olMailItem)
Dim acc, amm
Dim i&, j&, k&, m&, success, error
acc = Sheets("Email Address").Range("A1").CurrentRegion
amm = Sheets("Payment Request").Range("A1").CurrentRegion
success = 0
error = 0
ReDim bcc(1 To UBound(acc, 1), 1 To UBound(acc, 2))
For i = 2 To UBound(acc)
Name = acc(i, 1)
Email = acc(i, 2)
k = 0
m = 0
j = 1
For j = 1 To UBound(amm)
If amm(j, 1) = Name Then
If k = 0 Then
k = j
m = j
Else
m = j
End If
End If
Next
'outlook 发送邮件
If k <> 0 And m <> 0 Then
' On Error GoTo SendEmail_Error
With OutlookItem
.To = Email
.Subject = Name & " 付款申请已支付通知"
.HTMLBody = RangetoHTML(Sheets("Travel report application").Range("A1:E1")) & _
RangetoHTML(Sheets("Travel report application").Range("A" & k & ":E" & m)) & "<br><br>" & _
"Your payment request above is wiring today, please check your account in time. " & _
"<br><br>" & "(以上付款申请今天已支付，请通知收款方及时查账。）" & _
"<br><br>" & "XXXX." & _
"<br><br>" & "XXXX。"
.Send
End With
SendEmail_Exit:
success = success + 1
Set OutlookItem = Nothing
Set OutlookItem = OutlookApp.CreateItem(olMailItem)
GoTo Continue
SendEmail_Error:
error = error + 1
' MsgBox Err.Description
'Resume SendEmail_Exit
' Exit Sub
' MsgBox ("Name = " & Name & "Email = " & Email & " j = " & j & " k = " & k & " m = " & m)
Continue:
k = 0
m = 0
End If
Next
MsgBox ("成功发送邮件" & success & " ; 失败" & error)
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
