Sub PrintingPagesGenerator() '打印页生成器的 主程序
Dim str As String, pr As Long
Call DelSheets '呼叫删除sheets子程序，清理旧数据
Application.ScreenUpdating = False '关闭屏幕更新
Batches = Sheet2.[D100000].End(xlUp).Row '用Batches变量纪录 出货批次的最后行数
For i = 2 To Batches '从出货批次的第2行开始到最后一行执行循环
Application.StatusBar = "正在生成 第 " & i - 1 & " 批：" & Sheet2.Cells(i, 4) & " 的打印数据，还剩 " & Batches - i & " 批，请耐心等待。。。 。。。" '更新状态栏显示
Call CreateSheet '呼叫创建表子程序，根据模板创建
ActiveSheet.Name = Sheet2.Cells(i, 4) & "-" & Sheet2.Cells(i, 10) '改表名为批号+包数
For p = 1 To Val(Sheet2.Cells(i, 10)) '从1到批次的包数的循环，用来生成每包的打印页
pr = 1 + (p - 1) * 53 'pr变量 用来纪录每一包打印页开始的行号
With ActiveSheet
.Cells(pr, 2).Resize(9, 2) = Sheet3.[B1:C9].Value '将模板表上B1到C9区域内的文字信息，复制到当前表的当前包页面上
.Cells(pr + 4, 3) = Sheet2.Cells(i, 4) & "-" & Right(p + 100, 2) ' 添加包的批号+第N包次
.Cells(pr + 5, 3) = Sheet2.Cells(i, 9) ' 添加包的净重
.Cells(pr + 5, 4) = Sheet3.Cells(6, 4) ' 添加包的净重单位
.Cells(pr + 6, 3) = Sheet2.Cells(i, 6) ' 添加包的生产日期
str = "M2265-008993V0948100" & .Cells(pr + 5, 3) * 1000 & .Cells(pr + 4, 3) ' 计算QR的值并存到str中
.Cells(pr + 4, 10) = str ' 将这包qr码的值存在当前表上J列, 用于将来可能的备查验证
Call CreateQR(pr + 4, str) '呼叫创建QR码子程序，并将创建QR码需要的上距(top) 和 值(vlaue )传给它
Call CopyPIC(pr + 10) '呼叫创建添加图片子程序，并将插入图片的行号传过去
.HPageBreaks.Add before:=.Cells(pr + 53, 1) '插入打印分页符
End With
Next
ActiveSheet.PageSetup.PrintArea = "$A$1:" & ActiveSheet.Cells(pr + 52, 8).Address '设置当前表的A到F的打印区域。
Next
Sheet2.Select
Application.ScreenUpdating = True
Application.StatusBar = "打印数据，生成完毕！"
End Sub
Sub DelSheets() '用来清除旧sheet表的子程序
Application.DisplayAlerts = False '关闭删除警告
For i = 5 To Sheets.Count '删除第5个及以后的表
Sheets(Sheets.Count).Delete
Next
Application.DisplayAlerts = True
End Sub
Sub CreateSheet() ' 创建新表子程序 用来装每一批次的打印页
Sheet3.Copy After:=Sheets(Sheets.Count) ' 拷贝模板表成新表，并将新表放在最后
ActiveSheet.OLEObjects(1).Delete ' 删除当前表（新表）上的QR码
ActiveSheet.Pictures(1).Delete ' 删除当前表上的图片
ActiveSheet.Cells.ClearContents ' 清除当前表上的文字内容
End Sub
Sub CreateQR(rs As Long, v As String) '创建QR码的子程序，其中rs,v参数代表QR码位置的上距(top)和QR码值
'由于每个QR码在工作表上的行位置和值都不同，具体每一个QR码的rs,v
'值由调用它的PrintingPagesGenerator提供
Set qr = ActiveSheet.OLEObjects.Add("BARCODE.BarCodeCtrl.1") '添加一个QR码对象到当前工作表，并存到变量qr
qr.Width = 261 ' 设定QR码的宽度为261
qr.Height = 261 ' 设定QR码的高度为261
qr.Left = Sheet3.OLEObjects(1).Left ' 设定QR码的左边距与模板表上QR码的左边距相同
qr.Top = ActiveSheet.Cells(rs, 6).Top + 1 ' 设定QR码的上边距等于 当前表F列 rs 行的单元格的上距 加1
'(由于每包的QR码位置不同，这里每包的QR位置行也就是rs的计算由PrintingPagesGenerator提供)
qr.Object.Style = 11 ' 设定QR码样式为11， 11代码二维码
qr.Object.Validation = 2 ' QR Validation属性不知代码什么，通常是2
qr.Object.Value = v ' QR的值设为v, 其中v值 由调用它的 PrintingPagesGenerator 计算并提供
End Sub
Sub CopyPIC(rs As Long) ' 复制 粘贴图片子程序，负责把模板上的图片 粘贴到每包的打印页上，
'粘贴时每包的图片在表上的位置是不同的，其中rs参数由调用它的PrintingPagesGenerator提供以确定图片插入到正确位置
Sheet3.Pictures(2).Copy ' 复制 模板上的图片 Pictures(2), 在模板上 Pictures(2)是图片，Pictures(1)是二维码图片
With ActiveSheet
On Error Resume Next ' 如果粘贴时出错，继续执行粘贴后的下一行代码，不报错
wt1s: ' 插入个标记wt1s (只是个标记，无意义)
.Cells(rs, 1).PasteSpecial '刚才复制的图片 粘贴到在当前表的 rs 行，第1列
Debug.Print ActiveSheet.Name, rs, err.Number '调试时看的信息，无其他用处
If err.Number = 1004 Then '如发生错误代码等于1004就执行IF中的语句（正常err.number会是0），
'当图片粘贴得太快时(即图片还没有来得及复制到剪贴板之时)，粘贴就会出现1004错误，
'此时的容错处理是一旦发生1004错误，就等1秒钟再重新粘一次
Application.Wait (Now + TimeValue("00:00:01")) '让application在此等1秒钟
err.Number = 0 '清除错误代码
GoTo wt1s '跳转到 标记 wt1s
End If
On Error GoTo 0 '清除之前on error resume next的出错就继续下一行的设置
.Pictures(.Pictures.Count).Width = Sheet3.Pictures(2).Width '设最后添加的这个图片的宽度 为 模板上图片的宽度
.Pictures(.Pictures.Count).Height = Sheet3.Pictures(2).Height '设最后添加的这个图片的高度 为 模板上图片的高度
.Pictures(.Pictures.Count).Left = Sheet3.Pictures(2).Left '设最后添加的这个图片的左边距 为 模板上图片的左边距
.Pictures(.Pictures.Count).Top = .Cells(rs, 1).Top '设最后添加的这个图片的上距 为 模板上图片的上距
End With
End Sub

Sub SendToEmail() '发送邮件 主程序
Call CreatePDFs '呼叫生成PDF子程序 生成pdf文件
Subject = "标签打印数据" '邮件的标题
Body = "Hi, " & Chr(10) & Chr(10) & "参附件，本次需要打印的标签" '邮件正文，其中Chr(10)是换行
rs = Sheet2.[L1000].End(xlUp).Row '纪录发货批次上L列外仓人员邮件地址最后一行
If rs < 2 Then '如果rs小于2说明没有邮件地址，就提示并退出
MsgBox "<出货批次> 表上没有外仓收件人，请在L列添加收件人地址，再执行本程序！"
GoTo err
End If
Set msg = CreateObject("Outlook.Application").CreateItem(olMailItem) '创建邮件对象msg
msg.Subject = Subject '为邮件添加主题
msg.Body = Body '为邮件添加正文
For i = 2 To rs '为邮件添加收件人
msg.Recipients.Add (Sheet2.Cells(i, 12))
Next
For i = 5 To Sheets.Count '为邮件添加所有PDF附件
msg.attachments.Add ThisWorkbook.Path & "\" & Sheets(i).Name & ".pdf"
Next
msg.display '显示新建的邮件，并不发送
'msg.send '如果要直接发送邮件，将本行 msg.send 前的单引号去掉，同是将上一行的msg.display前加上单引号
err:
End Sub
Sub CreatePDFs() '按工作表生成pdf的子程序
Application.ScreenUpdating = False '关闭屏幕更新
sn = Sheets.Count - 4 'sn记下有几页要生成pdf, -4 是前四页不要生成
For i = 5 To Sheets.Count '从第5到最后一页执行循环
Application.StatusBar = "正在创建 " & Sheets(i).Name & ".pdf " & "共 " & sn & " 个 已完成 " & i - 4 & " 个，请稍候。。。" ' 更新状态栏进度显示
Sheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Sheets(i).Name, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ' 生成当表工作表名的pdf, 将保存在当前宏文件所有的文件夹下
Next
Application.StatusBar = "PDF文件创建完毕！"
Application.ScreenUpdating = True
End Sub

而你，是我们的英雄