EXCEL VBA发邮件,实现自动化批量发送
'以GET方式上传数据
Public Function uploadData_GET( ByVal url As String)
Dim http
Set http = CreateObject( "Microsoft.XMLHTTP" )
http. Open "GET" , url, False
http. send
Debug. Print http. getAllResponseHeaders
Debug. Print StrConv( http. responseBody, vbUnicode)
uploadData_GET = http. Status
Set http = Nothing
End Function
'以POST方式上传数据
Public Function uploadData_POST( ByVal url As String, ByVal data As String, ByVal Content As String)
Dim http
Set http = CreateObject( "Microsoft.XMLHTTP" )
http. Open "POST" , url, False
http. setRequestHeader "CONTENT-TYPE" , Content
http. send ( data)
Debug. Print http. getAllResponseHeaders
Debug. Print StrConv( http. responseBody, vbUnicode)
uploadData_POST = http. responseText
Set http = Nothing
End Function
'批量发送邮件,biubiu~ ~
Public Function biubiu( )
On Error Resume Next
Application. ScreenUpdating = False
ThisWorkbook. Worksheets( 1 ) . [ D1] . CurrentRegion. Clear
ThisWorkbook. Worksheets( 1. [ F1] . CurrentRegion. Clear
ThisWorkbook. Worksheets( 1 ) . [ D1] = "已下发"
ThisWorkbook. Worksheets( 1 ) . [ F1] = "未下发"
成功数量 = 0
失败数量 = 0
附件总数 = ThisWorkbook. Worksheets( 2 ) . [ A1] . CurrentRegion. Rows. Count - 1
批次发送量 = 200
For 行号 = 2 To 附件总数 + 1
'准备下发项验证
下发项 = ThisWorkbook. Worksheets( 2 ) . Cells( 行号, 1 )
下发项验证 = 0
下发项验证 = WorksheetFunction. CountIf( ThisWorkbook. Worksheets( 1 ) . [ C: C] , 下发项)
biuTrue = False '保存发送是否成功的返回值
If 下发项验证 > 0 Then
filePath = ThisWorkbook. Worksheets( 2 ) . Cells( 行号, 2 )
toMail_str = formatMail( WorksheetFunction. VLookup( 下发项, ThisWorkbook. Worksheets( 1 ) . [ C: E] , 2 , 0 ) )
ccMail_str = formatMail( WorksheetFunction. VLookup( 下发项, ThisWorkbook. Worksheets( 2 ) . [ C: E] , 3 , 0 ) )
mailSubject = 下发项 & "-" & ThisWorkbook. Worksheets( 1 ) . TextBox_邮件主题. Text
mailContent = ThisWorkbook. Worksheets( 1 ) . TextBox_邮件内容. Text
mailContent = Replace( mailContent, Chr( 13 ) & Chr( 10 ) , "<br>" )
biuTrue = biu( filePath, toMail_str, ccMail_str, mailSubject, mailContent) 'biu发送一封
End If