Sub Final_Batch_Full_List_Confirm()
' --- 1. 变量声明段 ---
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Dim wsSettings As Worksheet, wsData As Worksheet
Dim templatePath As String, saveRule As String, dataSheetName As String
Dim startID As Long, endID As Long, currentID As Long, r As Long, c As Long
Dim lastCol As Long, colLetter As String, count As Integer: count = 0
Dim folderPath As String, dynamicFileName As String, fileExt As String
Dim allFilesList As String ' 用于存储弹窗显示的完整文件清单
' --- 2. 参数读取段 ---
Set wsSettings = ActiveSheet ' 设定当前点击按钮的表为控制表
templatePath = Trim(wsSettings.Range("B2").Value)
dataSheetName = Trim(wsSettings.Range("B3").Value)
startID = wsSettings.Range("B4").Value
endID = wsSettings.Range("B5").Value
saveRule = Trim(wsSettings.Range("B6").Value)
' --- 3. 环境检查段 ---
On Error Resume Next
Set wsData = ThisWorkbook.Sheets(dataSheetName) ' 尝试锁定数据表
If Err.Number <> 0 Then
MsgBox "错误：找不到名为 '" & dataSheetName & "' 的工作表，请检查B3单元格！", vbCritical
Exit Sub
End If
On Error GoTo 0
' 解析保存规则中的文件夹路径 (获取最后一个反斜杠之前的内容)
If InStrRev(saveRule, "\") > 0 Then
folderPath = Left(saveRule, InStrRev(saveRule, "\"))
fileExt = ".docx"
Else
MsgBox "错误：B6保存路径缺少文件夹位置！", vbCritical: Exit Sub
End If
' --- 4. 启动 Word 引擎 ---
Set wdApp = CreateObject("Word.Application") ' 后期绑定，无需手动引用库
wdApp.Visible = False ' 后台运行，提高速度
' 获取数据表最后一列的范围
lastCol = wsData.Cells(1, wsData.Columns.count).End(xlToLeft).Column
' --- 5. 核心处理循环 ---
For currentID = startID To endID
r = currentID + 1 ' 关键逻辑：ID 1 对应数据表的第 2 行
' 仅处理 B 列不为空的行，防止空跑
If wsData.Cells(r, 2).Text <> "" Then
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True) ' 以只读方式打开模板
' A. 遍历列进行替换
For c = 2 To lastCol
colLetter = Split(wsData.Cells(1, c).Address, "$")(1) ' 获取列字母 (B, C, D...)
Dim placeholder As String, content As String
placeholder = "$" & colLetter & "2" ' 生成占位符，如 $B2
content = wsData.Cells(r, c).Text ' 获取当前行单元格内容
Set wdRng = wdDoc.content
With wdRng.Find
.ClearFormatting
.Text = placeholder
Do While .Execute
' B. 图片识别逻辑：如果内容是有效的本地图片路径
If (InStr(content, ":\") > 0 Or InStr(content, "/") > 0) And _
(Right(LCase(content), 4) = ".jpg" Or Right(LCase(content), 4) = ".png" Or Right(LCase(content), 5) = ".jpeg") And _
Dir(content) <> "" Then
wdRng.Text = "" ' 删掉占位符文字
Dim shp As Object
Set shp = wdDoc.InlineShapes.AddPicture(fileName:=content, LinkToFile:=False, SaveWithDocument:=True, Range:=wdRng)
shp.LockAspectRatio = True ' 锁定纵横比
shp.Width = 350 ' 设置宽度为 350 磅 (约 12.3 厘米)
Else
' C. 文本替换逻辑
wdRng.Text = content
End If
wdRng.Collapse 0 ' 继续向下查找，防止同一占位符多次出现只替换一个
Loop
End With
Next c
' --- 6. 动态文件名解析段 ---
' 提取 B6 中 \ 之后的文件名模板
dynamicFileName = Mid(saveRule, InStrRev(saveRule, "\") + 1)
' 去掉后缀名干扰
If InStr(dynamicFileName, ".") > 0 Then dynamicFileName = Left(dynamicFileName, InStrRev(dynamicFileName, ".") - 1)
' 将文件名模板中的 $B2 等替换为实际内容
For c = 1 To lastCol
Dim tempColLetter As String
tempColLetter = Split(wsData.Cells(1, c).Address, "$")(1)
Dim filePlaceholder As String
filePlaceholder = "$" & tempColLetter & "2"
If InStr(dynamicFileName, filePlaceholder) > 0 Then
dynamicFileName = Replace(dynamicFileName, filePlaceholder, wsData.Cells(r, c).Text)
End If
Next c
' --- 7. 保存与归档 ---
count = count + 1
Dim finalName As String: finalName = dynamicFileName & fileExt
wdDoc.SaveAs2 folderPath & finalName
wdDoc.Close False ' 关闭 Word 文档，不保存模板更改
' 累加文件名清单用于最后的报告
allFilesList = allFilesList & count & ". " & finalName & vbCrLf
End If
Next currentID
' --- 8. 释放资源与反馈 ---
wdApp.Quit
Set wdApp = Nothing
' 弹出最终生成的清单报告
MsgBox "处理成功！" & vbCrLf & _
"共生成文件：" & count & " 个" & vbCrLf & _
"------------------------" & vbCrLf & _
allFilesList, vbInformation, "生成报告"
End Sub
|
