账务每个月发工资条给每个员工可以用这个办法一键搞定。
老师给学生布置作业也可以用这个办法轻松完成。
很多大量的工作我们在 Excel 里面完成后发送给领导及相关人员如果是一条条发送真是太费时间了，当人多的时候让你复制邮箱号也够让你手累眼花的。
当有了批量发送模板文件你只需要把信息内容导进去就可以了，剩下时间交给电脑你就安心刷你的视频。
实现功能：批量发送邮箱
下面是代码分享
写代码前、前期准备
<a href="https://p3-sign.toutiaoimg.com/pgc-image/04c7a63caca644faa3291d4658ef6a90~
These are the steps needed for preparation. I used a QQ mailbox to send emails. You can also send emails using an Outlook mailbox account. However, my test failed. I'm not sure if there was something wrong with the settings or if it was because I applied for a free account.
The following is the code:
Sub SendMailEnvelope()
Dim avntWage As Variant
Dim i As Long
Dim strText As String
Dim objAttach As Object
Dim strPath As String
With Application
.ScreenUpdating = False 'Disable screen updates for faster code execution
.EnableEvents = False 'Disable events. Launching disabling events will not trigger the following automatic events
End With
strPath = ThisWorkbook.Path & "\Notice Regarding Corporate Employee Wage Adjustments.docx"
'------------Path to attachment in email
avntWage = Sheets("工资表").[a1].CurrentRegion
'------------Load data from the wage sheet into an array
For i = 2 To UBound(avntWage)
[a2:i2] = Application.Index(avntWage, i)
'------------Load wage slip data into range a2:i2
[b1:i2].Select
'------------Select b1:i2 as email body table content
ActiveWorkbook.EnvelopeVisible = True 'If the email writing title and envelope toolbar are visible
'------------MailEnvelope visible
With ActiveSheet.MailEnvelope 'Indicates the email header of the document
strText = avntWage(i, 2) & "Dear recipient:" & vbCrLf & "Here's your " & _
avntWage(i, 3) & " wage statement for review!"
.Introduction = strText
'------------Email body
With .Item
.To = avntWage(i, 1)
'------------Recipient
.CC = "244021952@qq.com"
'.CC = "treasurer@gmail.com"
'------------CC
.Subject = avntWage(i, 3) & " Wage Statement for Month"
'------------Subject
Set objAttach = .Attachments 'Contains a collection that represents the attachments in Outlook items
Do While objAttach.Count > 0
'------------Do While Statement to delete any old attachments that might exist
objAttach.Remove 1 'Remove from the AccessObjectProperties collection of the object
'MsgBox objAttach.Count
Loop
.Attachments.Add strPath
'------------Add new attachment
.send
'------------Send email
End With
End With
Next i
ActiveWorkbook.EnvelopeVisible = False
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objAttach = Nothing
End Sub