邮件群发

MáοMáο゛趙

各位大佬，用这个邮件群发，提示如图，要怎么办啊


Public Declare Function SetTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long
Public Declare Function KillTimer Lib "user32" _
        (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'批量发送邮件
Sub BatchSendMail()
    Dim rowCount, endRowNo
    endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
    '逐行发送邮件
    For rowCount = 2 To endRowNo
        SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4), Cells(rowCount, 5), 0
    Next
End Sub

'批量保存邮件
Sub BatchSaveMail()
    Dim rowCount, endRowNo
    endRowNo = Cells(1, 1).CurrentRegion.Rows.Count
    '逐行发送邮件
    For rowCount = 2 To endRowNo
        SendMail Cells(rowCount, 1), Cells(rowCount, 2), Cells(rowCount, 3), Cells(rowCount, 4), Cells(rowCount, 5), 1
    Next
End Sub
  
' 发送多个附件，用;隔开
' 发送单个邮件的子程序
Sub SendMail(ByVal to_who As String, ByVal ccto_who As String, ByVal subject As String, ByVal body As String, ByVal attachement As String, ByVal i As Integer)
    Dim objOL As Object
    Dim itmNewMail As Object
    Dim attaches
    Dim attach
      
    '引用Microsoft Outlook 对象
    Set objOL = CreateObject("Outlook.Application")
    Set itmNewMail = objOL.CreateItem(olMailItem)
    With itmNewMail
        .subject = subject      '标题
        .HTMLbody = body        '正文本文
        .To = to_who            '收件者
        .CC = ccto_who          '抄送
        .Display                '启动Outlook发送窗口
        attaches = Split(attachement, ";")
         
        For Each attach In attaches
            If (Len(attach) > 0) Then
                .Attachments.Add attach
            End If
        Next
        
        If i = 0 Then
            SetTimer 0, 0, 0, AddressOf WinProcA0
        ElseIf i = 1 Then
            SetTimer 0, 0, 0, AddressOf WinProcA1
        End If
    End With
      
    Set objOL = Nothing
    Set itmNewMail = Nothing
End Sub


Function WinProcA0(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
    KillTimer 0, idEvent
    DoEvents
    Sleep 100
    '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了
    Application.SendKeys "%s"
    '使用Ctrl+S保存邮件到草稿箱
'    Application.SendKeys "^s"
End Function

Function WinProcA1(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal SysTime As Long) As Long
    KillTimer 0, idEvent
    DoEvents
    Sleep 100
    '使用Alt+S发送邮件，这是本文的关键之处，免安全提示自动发送邮件全靠它了
'    Application.SendKeys "%s"
    '使用Ctrl+S保存邮件到草稿箱
    Application.SendKeys "^s"
End Function

MáοMáο゛趙

有人答复下不

smsn

红色部分引用api是32系统使用，要转为64位才能用。另外这程序用outlook发邮件，首先outlook要先配置好，正常使用后，才能用vba发送邮件发。你去试下 cdo.message  百度下 vba cdo.message mail有例子