EXCEL VBA发邮件，实现自动化批量发送

码猩2024-07-09 23:29
EXCEL VBA发邮件，实现自动化批量发送

python 复制代码
'以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