VBA通过SMTP发送邮件 – 老狼的窝-wolfccb

以下代码在WPS中测试通过，Office应该也没有兼容性问题。其中的writeLog我注释掉了，如果需要写log可以自行修改，建议用这个VBA记录Log小工具。代码里那个奇怪的网址是微软CDO.Message设置参数时必须的，只能如此。

Sub sendMail(ByVal mailSubject As String, ByVal mailSendTo As String, ByVal mailText As String, ByVal attachFileName As String, ByVal SMTPUsername As String, ByVal Password As String, ByVal SMTPServer As String, ByVal SMTPPort As Integer)
    
    On Error GoTo errhandler
    
    Dim oMsg As Object
    sMsUrl = "http://schemas.microsoft.com/cdo/configuration/"
    
    Set oMsg = CreateObject("CDO.Message")

    With oMsg.Configuration.Fields
        .Item(sMsUrl & "smtpserver") = SMTPServer
        .Item(sMsUrl & "smtpserverport") = SMTPPort
        .Item(sMsUrl & "sendusing") = 2    '使用端口发送
        .Item(sMsUrl & "smtpauthenticate") = 1    '需要smtp认证
        .Item(sMsUrl & "sendusername") = SMTPUsername
        .Item(sMsUrl & "sendpassword") = Password
        .Update
    End With
        
    'writeLog ("CDO.Message configured")
    
    With oMsg
        .From = SMTPUsername
        .To = mailSendTo
        .Subject = mailSubject
        .TextBody = mailText
        If attachFileName <> "" Then .AddAttachment attachFileName
    End With
    
    'writeLog ("CDO.Message mail created")
    
    oMsg.send
    'writeLog ("Mail sent. " & mailSubject)
    Set oMsg = Nothing
    Exit Sub
    
errhandler:
    'writeLog Err.Number & " " & Err.Description
    Set oMsg = Nothing
    
End Sub

以上。

持续自动化的老狼