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
