ExcelVBA调用CDO控件批量发QQ邮件并添加不同附件

      Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) '64位系统，sleep用到的
    'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)'32位系统，sleep用到的
Sub yhd批量邮件()
    On Error Resume Next                                       '出错后继续执行
    Dim sucess, fail
    disAppSet (False)
    t = Time()
    sucess = 0
    fail = 0
    With Worksheets("批量邮件")
        M_From = .Range("B2").Value
        M_sendpassword = .Range("D2").Value
        M_sendusername = .Range("F2").Value
        M_Subject = .Range("H2").Value
        For i = 5 To 52 '.Cells(Rows.Count, 1).End(xlUp).Row
            M_To = .Range("F" & i).Value
            M_TextBody = .Range("G" & i).Value
            M_AddAttachment = .Range("H" & i).Value
            If .Range("I" & i).Value = "y" Then
                Set CDOMail = CreateObject("CDO.Message")      '创建对象
                CDOMail.From = M_From                          '设置发信人的邮箱
                CDOMail.To = M_To                              '设置收信人的邮箱
                CDOMail.Subject = M_Subject                    '设定邮件的主题
                CDOMail.TextBody = M_TextBody                  '使用文本格式发送邮件
                '    CDOMail.Htmlbody = a                      '使用Html格式发送邮件
                CDOMail.AddAttachment M_AddAttachment          '发送附件
                stUl = "http://schemas.microsoft.com/cdo/configuration/"    '微软服务器网址
                With CDOMail.Configuration.Fields
                    .Item(stUl & "smtpusessl") = True
                    .Item(stUl & "smtpserver") = "smtp.qq.com" 'SMTP服务器地址
                    .Item(stUl & "smtpserverport") = 465       'SMTP服务器端口
                    .Item(stUl & "sendusing") = 2              '发送端口
                    .Item(stUl & "smtpauthenticate") = 1       '远程服务器需要验证
                    .Item(stUl & "sendusername") = M_sendusername    '发送方邮箱名称
                    .Item(stUl & "sendpassword") = M_sendpassword    '上面连接生成的授权码，非你qq邮箱密码" '发送方邮箱密码
                    .Item(stUl & "smtpconnectiontimeout") = 60 '连接超时(秒)
                    .Update
                End With
                CDOMail.Send                                   '执行发送
                Set CDOMail = Nothing                          '发送成功后即时释放对象
                Sleep (3000)                                   '暂停3秒
                If Err.Number = 0 Then
                    '            MsgBox "成功发送邮件", , "温馨提示" '如果没有出错，则提示发送成功
                    .Cells(i, 10).Value = "成功"
                    sucess = sucess + 1
                Else
                    '            MsgBox Err.Description, vbInformation, "邮件发送失败"    '如果出错，则提示错误类型和错误代码
                    .Cells(i, 10).Value = "失败"
                    fail = fail + 1
                End If
            Else
                .Cells(i, 10).Value = "没来要"
            End If
        Next i
        On Error GoTo 0
        MsgBox ("发送完成，用时" & DateDiff("s", t, Time()) & "s,【成功】=" & sucess & "【失败】=" & fail)
    End With
    disAppSet (True)
End Sub

Sub 选择附件()
    Dim fileToOpen
    disAppSet (False)
    ChDir ThisWorkbook.Path
    fileToOpen = Application.GetOpenFilename("Excel文件,*.xls*", 1, MultiSelect:=True)
    If Not IsArray(fileToOpen) Then MsgBox ("你没有选择文件，将退出"): Exit Sub
    With Worksheets("批量邮件")
        n = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 5 To n
            sch = .Cells(i, 2).Value
            For Each f In fileToOpen
                If InStr(1, f, sch) Then .Cells(i, 8).Value = f
            Next
        Next i
    End With
    disAppSet (True)
End Sub
    '用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
    With Application
        .ScreenUpdating = flag
        .DisplayAlerts = flag
        .AskToUpdateLinks = flag
        If flag Then
            .Calculation = xlCalculationAutomatic
        Else
            .Calculation = xlCalculationManual
        End If
    End With
End Sub