【问题】近来我要进行这样的工作，每月下属的单位要来GZ明细。要求：A单位发A单位人员的明细，B单位发B单位人员的明细，简单说就是不同单位发不同单位的人员的明细，（PS:以前人家的做法是全部人员发下去，那么就出现每个单位收到的是所有全部人员的资料，这出现资料信息XM的问题） |
|---|
【正常做法】在QQ中进行私发文件，A单位要---（1）在文件夹中找到A文件复制---（2）在Q打开私聊窗口---（3）发送文件---（4）发送相关的提示文字---（5）完成1个，B单位要---（1）……--（2）……---（3）……---（4）……---（5）完成2个，…………每个月每次都有几个单位来GZ明细，我每次都操作到手都酸痛得不得了。累人 |
【想想方法】能不能，谁要文件做个记号"y",全部记好，群发邮件，A单位的发A单位的附件，B单位的发B单位的附件，……，简单说就是群发邮件，每邮件发不同的相应的附件，一键群发。Yeah, |
【准备工作】网上学习到有两种方法：一是VBA调用OutLook控件进行发送，这要在电脑中安装Office OutLook,(可惜我的电脑没有安装)，一是VBA调用CDO控件，再利用QQ邮箱发送，好了 |
QQ邮箱设置：
打开mail.qq.com---设置---帐户---开启POP3---生成授权码
复制出授权码
下面开始设计我自己的工具啦，我们的口号是VBA使工作效率更高
【工具界面】
设定：
（1）发送邮箱：自己设定固定
（2）授权号：自己设定固定
（3）邮箱名称：自己设定固定
（4）邮件主题：每月不同
（5）Mail_To邮箱：程序循环读取
（6）邮件内容：程序循环读取
（7）邮件附件：程序循环读取
（8）是否发送：要求要的单位 设定“y”，程序判断再发送，
（9）是否成功：程序反馈
【代码】
代码语言：javascript复制 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听说，如果我们用程序调用CDO，再调用QQ邮件系统发送邮件时，如果发送太快太PF,系统可能会把你的QQ邮箱功能锁定，所以加了Sleep(3000)函数
【其他有用的代码】
代码语言：javascript复制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
复习点知识:Application.GetOpenFilename相当于Excel的文件打开功能，Application.GetOpenFilename 方法显示标准的“打开”对话框，并获取用户文件名，而不必真正打开任何文件，只是把打开文件名称返回程序。'GetOpenFilename相当于Excel打开窗口，通过该窗口选择要打开的文件，并可以返回选择的文件完整路径和文件名。返回值Variant说明如果点击了取消，返回false 语法：'Application.GetOpenFilename(文件类型筛选规则,优先显示第几个类型的文件,标题,是否允许选择多个文件名)表达式.GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)表达式 一个代表 Application 对象的变量。我们对返回是“打开”或“取消”要进行 Not isArray()判断 |
|---|
【测试成功】
希望能提高我的工作效率，使工作变得轻松，
如果你也有这样的需要，可以复制使用，我们学习，是为了不加班，如果你学习到知识，请转发给更多人学习。
试读到此已全部内容啦，哈哈，哈哈，
如果你有问题可加我QQ:284571545,我们共同学习讨论
