excel vba 批量发送邮件邮件内容放入表格指定主题

TomingTang

最近工作中遇到同事经常要发送销售日报之类的，邮件内容极为相似，
发送内容有：邮件主题，报表，报表附件，发送抄送不同人员。
本分享实现内容，可以填入不同发送服务器，不同工作表、附件、发送给对应的接收人，邮件主题，邮件主要内容可以自定义，也可以默认进行发送。

附件说明：
工作表：“查询按钮”
B1：b3，填写发送邮件服务器，发送邮箱，发送邮箱密码

B9：c16填写邮件接收人、抄送人员邮箱，多个接收人用 分号  分隔，
E9：f16是指定邮件的主题、内容，不填写空白的，就按照默认的发送。。


按钮：“发送邮件”，点击，选择要发送那个工作表，这个是按照我同事需要设计的。可以对应进行修改。

程序比较乱，可以参考一下。。
附件删除了大部分内容、数据，其实还有部分是 从sql server提取数据，然后进行汇总。最后发送邮件的。后面 连接sql server 数据库进行数据汇总处理的，后面再进行分享。
谢谢。

outlook VBA自动发送邮件.zip (107.91 KB, 下载次数: 290)

2016-8-9 12:55 上传

点击文件名下载附件

附件代码：

1. 
   

复制代码

TomingTang

附件代码：

1. 
   
2. Sub SendEmail_All(EmailPort, MailServer, shtname)
   
3. 'MsgBox shtname
   
4. 'Unload UserForm3
   
5.     r1 = Worksheets("UK").[a65536].End(xlUp).Row   ' 开始全部客户占的最后行数
   
6.     c = Range("iv1").End(xlToLeft).Column
   
7.     Dim NameSpace$, Email As Object, ns$, n%
   
8.     NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
   
9.     Set Email = CreateObject("CDO.Message")
   
10.     '  UserForm1.Show 0    '激活进度条
    
11.     ' '设置进度条控件
    
12.     '   With UserForm1.ProgressBar1
    
13.     '      .Min = 1    '设置进度条控件的最小值
    
14.     '     .Max = r1  '设置进度条控件的最大值
    
15.     '      .Scrolling = 0
    
16.     '  End With
    
17.     '  For i = 2 To r1  '按照准备发送的客户数
    
18.     's2 = hbdyg(Range(Cells(i, 3), Cells(i, c)), "|")
    
19.     ''发送准备工作
    
20.     Email.From = Worksheets("查询按钮").Range("b2")                         'WorkSheets("查询按钮").Range("g2") & "@qq.com"    '发件人QQ邮箱=“辅助工作表”G2
    
21.     Email.To = Mail_Arr(d_Mail(shtname), 2)   ' Worksheets("查询按钮").Range("b9")   '要发往的地址=“辅助工作表”D列
    
22.     Email.cc = Mail_Arr(d_Mail(shtname), 3)    ' "jianming.tang@chukou1.com"   ' Mail_Arr(d_Mail(shtname), 3)
    
23.     If shtname = "各仓汇总" Then
    
24.         If Mail_Arr(d_Mail(shtname), 5) <> "" Then
    
25.             Email.Subject = Mail_Arr(d_Mail(shtname), 5)
    
26.         Else
    
27.             Email.Subject = Format(Now() - 1, "m.d") & "海外仓内部结算日报表"
    
28.         End If
    
29. 
    
30.         If Mail_Arr(d_Mail(shtname), 6) <> "" Then
    
31.             Email.Htmlbody = "<p>" & Worksheets("查询按钮").Range("F9") & "</p>" & getval(shtname)        ' Worksheets("查询按钮").Range("F5") & "<br/>" & getval(shtname)   'getVal(i)    'HTML形式正文（加入表格部分行）
    
32.         Else
    
33.             Email.Htmlbody = "<p>" & "Dear All: " & "</p><p> " & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;附件是截止" & Format(Now() - 1, "yy年m月d日") & "海外仓内部结算收入日报表（含各仓数据、汇总数据），请查收，谢谢！" & "</p><p>" _
    
34.                            & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;备注：线下登记的FBA出库数据截止" & Format(Now() - 1, "d日") & "，专线数据截止" & Format(Now() - 1, "d日") & "。" & "</p>" & getval(shtname)
    
35.         End If
    
36. 
    
37.         Email.AddAttachment ThisWorkbook.Path & "\海外仓内部结算收入日报" & Format(Now() - 1, "yy年m月") & "内部结算收入-" & Format(Now() - 1, "m.d") & ".xlsx"    '添加附件
    
38.     Else
    
39.         If Mail_Arr(d_Mail(shtname), 5) <> "" Then
    
40.             Email.Subject = Mail_Arr(d_Mail(shtname), 5)
    
41.         Else
    
42.             Email.Subject = Format(Now() - 1, "m.d") & shtname & " 仓海外仓内部结算日报表"    '标题=“辅助工作表”G4
    
43.         End If
    
44. 
    
45.         If Mail_Arr(d_Mail(shtname), 6) <> "" Then
    
46.             Email.Htmlbody = "<p>" & Worksheets("查询按钮").Range("F9") & "</p>" & getval(shtname)       ' Worksheets("查询按钮").Range("F5") & "<br/>" & getval(shtname)   'getVal(i)    'HTML形式正文（加入表格部分行）
    
47.         Else
    
48.             Email.Htmlbody = "<p>" & "Dear All: " & "</p><p> " & "       附件是截止" & Format(Now() - 1, "yy年m月d日") & "海外仓内部结算收入日报表（币种：人民币），请查收，谢谢！" & "</p>" & getval(shtname)
    
49.             '  Email.Htmlbody = "Dear All: " & vbCrLf & "       附件是截止" & Format(Now() - 1, "yy年m月d日") & "海外仓内部结算收入日报表（币种：人民币），请查收，谢谢！" & vbCrLf & getval(shtname)
    
50.         End If
    
51.         Email.AddAttachment ThisWorkbook.Path & "\海外仓内部结算收入日报" & shtname & "仓" & Format(Now() - 1, "m月") & "内部结算收入-" & Format(Now() - 1, "m.d") & ".xlsx"  '添加附件
    
52. 
    
53.     End If
    
54.     'Email.Textbody =WorkSheets("UK").Range("a" & i) & Chr(10) & s1 & Chr(10) & s2 '文本形式正文
    
55.     If shtname = "UK" Then
    
56.         Email.Subject = Format(Now() - 1, "m.d") & "UK warehouse internal settlement daily report "
    
57.         Email.Htmlbody = "<p>" & "Hi Steve: " & "</p><p> " & "&nbsp;&nbsp;&nbsp;Attachment is on" & Format(Now() - 1, "mmmm dd") & "， income from settlement of  warehouse internal daily report ,  thank you!" & "</p>" & getval(shtname)
    
58.     End If
    
59. 
    
60. 
    
61.     With Email.Configuration.Fields
    
62.         .Item(NameSpace & "smtpusessl") = 1
    
63.         .Item(NameSpace & "sendusing") = 2
    
64.         .Item(NameSpace & "smtpserver") = MailServer  '"smtp.qq.com"    '发送邮件服务器
    
65.         .Item(NameSpace & "smtpserverport") = EmailPort         ' "465"
    
66.         .Item(NameSpace & "smtpauthenticate") = 1
    
67.         .Item(NameSpace & "sendusername") = Worksheets("查询按钮").Range("b2")             '   WorkSheets("查询按钮").Range("g2") & "@qq.com"    '发件人QQ邮箱
    
68.         .Item(NameSpace & "sendpassword") = Worksheets("查询按钮").Range("b3")    '发件人QQ密码
    
69.         .Update
    
70.     End With
    
71.     Email.send    ''发送
    
72. 
    
73.     '   '进度条
    
74.     '   UserForm1.ProgressBar1.Value = 1
    
75.     ' UserForm5.Caption = Worksheets("UK").Range("c" & i) & "  的邮件（含附件）已发送。请稍候!"
    
76.     DoEvents    '把控制权交给VBA
    
77.     '   Next i
    
78.     Unload UserForm1
    
79.     'MsgBox "文件已经全部发送完成。"
    
80. 
    
81.     '
    
82. 100:
    
83.     If Err.Number <> 0 Then    '处理错误
    
84.         If Err.Number = -2147220977 Then
    
85.             MsgBox "收信人地址 “" & Add & "” 错误! "
    
86.         ElseIf Err.Number = -2147220980 Then
    
87.             MsgBox "错误! 收信人地址未填写"
    
88.         ElseIf Err.Number = -2147220973 Then
    
89.             MsgBox "网络未连接! "
    
90.         Else
    
91.             MsgBox "其他错误!（超时、附件太大、邮箱已满） "
    
92.         End If
    
93.         End
    
94.     End If
    
95. End Sub
    
96. 
    
97. 
    
98. 
    
99. Sub SendEmail(ByVal shtname As String)
    
100.     Dim sht$, i%, EmailType$, EmailPort$, MailServer$, Arr
     
101.     Set d_Mail = CreateObject("scripting.dictionary")
     
102. 
     
103.     With Worksheets("查询按钮")
     
104.         Mail_Arr = .Range("a9:f16")
     
105.         For i = 1 To UBound(Mail_Arr)
     
106.             d_Mail(Mail_Arr(i, 1)) = i
     
107.         Next
     
108. 
     
109.         EmailType = .Range("b1")
     
110.         Select Case EmailType
     
111.         Case "qq"
     
112.             EmailPort = "465"
     
113.             MailServer = "smtp.qq.com"
     
114.         Case "企业邮箱"
     
115.             EmailPort = "465"
     
116.             MailServer = "smtp.exmail.qq.com"
     
117.         Case "126"
     
118.             EmailPort = "465"
     
119.             MailServer = "smtp.126.com"
     
120.         Case "163"
     
121.             EmailPort = "465"
     
122.             MailServer = "smtp.163.com"
     
123.         Case "gmail"
     
124.             EmailPort = "465"
     
125.             MailServer = "smtp.gmail.com"
     
126.         End Select
     
127.         ' shtname = "UK"
     
128.         Call SendEmail_All(EmailPort, MailServer, shtname)
     
129. 
     
130.     End With
     
131. 
     
132. 
     
133. End Sub
     
134. 
     
135. 
     
136. Sub 发送邮件_最终()
     
137. ' Dim myForm As 发送邮件
     
138. 
     
139. '  Set myForm = New 发送邮件
     
140. ' myForm.show
     
141.     发送邮件.show
     
142.     '  Set myForm = Nothing
     
143. End Sub
     

复制代码

seide

留下脚印，回头来参考

张明敏

有问题求助，方便联系一下吗？联系方式QQ6671529，微信1043078042，谢谢

zhangy531

学习一下，老厉害了