前一篇文章完成了批次產生桌牌或名牌的圖檔
再來就是輸出了
由於辦公室的影印機可以輸出A4、A3跟B4
所以我用A4格式來設定
名牌，一張A4，2欄2列(2*2)的表格，4張圖
桌牌，一張A4，1欄5列(1*5)的表格，1張圖，用2次，其中一張翻轉180度
我先建立Word範本，再用Excel VBA批次替換圖片
工作表"設定頁面"，顧名思義就是設定word範本來源與圖檔來源
可以自己手動輸入，也可以用VBA抓取，我是用兩個程序來執行
寫入的圖檔來源完整路徑，並分割字串取得檔案名稱
選擇Word範本跟圖檔來源的程式碼
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
' ==========================================
' 按鈕 1：選擇 Word 範本
' ==========================================
Sub SelectWordTemplate()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "請選擇 Word 範本檔"
.Filters.Clear
.Filters.Add "Word 文件", "*.docx; *.docm"
.AllowMultiSelect = False
If .Show = -1 Then Sheets("設定頁面").Range("B2").Value = .SelectedItems(1)
End With
End Sub
' ==========================================
' 按鈕 2：選擇資料夾並列出圖檔
' ==========================================
Sub SelectImageFolderAndList()
Dim fd As FileDialog
Dim folderPath As String, fileName As String
Dim wsList As Worksheet
Dim rowCounter As Integer
Set wsList = Sheets("圖檔清單")
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "請選擇包含圖片的資料夾"
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Sheets("設定頁面").Range("B3").Value = folderPath
Else
Exit Sub
End If
End With
wsList.Cells.Clear
wsList.Range("A1").Value = "圖檔完整路徑"
wsList.Range("B1").Value = "檔名"
rowCounter = 2
fileName = Dir(folderPath & "*.*")
Do While fileName <> ""
If IsImageFile(fileName) Then
wsList.Cells(rowCounter, 1).Value = folderPath & fileName
wsList.Cells(rowCounter, 2).Value = Left(fileName, InStrRev(fileName, ".") - 1)
rowCounter = rowCounter + 1
End If
fileName = Dir
Loop
MsgBox "讀取完畢，共 " & (rowCounter - 2) & " 張圖片。", vbInformation
End Sub
' 按鈕 1：選擇 Word 範本
' ==========================================
Sub SelectWordTemplate()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "請選擇 Word 範本檔"
.Filters.Clear
.Filters.Add "Word 文件", "*.docx; *.docm"
.AllowMultiSelect = False
If .Show = -1 Then Sheets("設定頁面").Range("B2").Value = .SelectedItems(1)
End With
End Sub
' ==========================================
' 按鈕 2：選擇資料夾並列出圖檔
' ==========================================
Sub SelectImageFolderAndList()
Dim fd As FileDialog
Dim folderPath As String, fileName As String
Dim wsList As Worksheet
Dim rowCounter As Integer
Set wsList = Sheets("圖檔清單")
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "請選擇包含圖片的資料夾"
If .Show = -1 Then
folderPath = .SelectedItems(1) & "\"
Sheets("設定頁面").Range("B3").Value = folderPath
Else
Exit Sub
End If
End With
wsList.Cells.Clear
wsList.Range("A1").Value = "圖檔完整路徑"
wsList.Range("B1").Value = "檔名"
rowCounter = 2
fileName = Dir(folderPath & "*.*")
Do While fileName <> ""
If IsImageFile(fileName) Then
wsList.Cells(rowCounter, 1).Value = folderPath & fileName
wsList.Cells(rowCounter, 2).Value = Left(fileName, InStrRev(fileName, ".") - 1)
rowCounter = rowCounter + 1
End If
fileName = Dir
Loop
MsgBox "讀取完畢，共 " & (rowCounter - 2) & " 張圖片。", vbInformation
End Sub
SelectImageFolderAndList()會再透過一個副程序來檢測附檔名是否為jpg、png、 jpeg
可以視需求修改程式碼
1
2
3
4
5
2
3
4
5
Function IsImageFile(fName As String) As Boolean
Dim ext As String
ext = LCase(Right(fName, 4))
IsImageFile = (ext = ".jpg" Or ext = ".png" Or ext = ".bmp" Or LCase(Right(fName, 5)) = ".jpeg")
End Function
Dim ext As String
ext = LCase(Right(fName, 4))
IsImageFile = (ext = ".jpg" Or ext = ".png" Or ext = ".bmp" Or LCase(Right(fName, 5)) = ".jpeg")
End Function
主程式
現在的版本可以透過範本內表格的欄數、列數自動選定執行模式
1*5，桌牌模式；2*2，名牌模式
所以在試算表"設頁頁面"的執行模式已經沒有作用
另一個可能也比較沒有作用的是"桌牌模式"
單獨，指的是每一個桌牌是獨立的docx檔案
合併，就是將所有桌牌替換在同一個docx檔案
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
' ==============================================================================
' ==============================================================================
' 按鈕 3：智慧總執行按鈕 (Auto-Detect Master Controller)
' 功能：自動判斷 Word 範本表格結構，決定跑哪種模式
' ==============================================================================
Sub MasterExecute_Smart()
Dim templatePath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rowCount As Long, colCount As Long
Dim modeName As String
Dim modeName2 As String
' 1. 檢查範本路徑
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
' 2. 背景啟動 Word 進行偵測
Application.StatusBar = "正在偵測範本格式..."
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = False ' 偵測時不顯示，以免畫面閃爍
' 3. 開啟範本讀取表格資訊
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
' 預設值
rowCount = 0
colCount = 0
If wdDoc.Tables.Count >= 1 Then
Set tbl = wdDoc.Tables(1)
' 取得列數與欄數
' 注意：若表格有合併儲存格，Columns.Count 可能會報錯，故加強防護
On Error Resume Next
rowCount = tbl.Rows.Count
colCount = tbl.Columns.Count
On Error GoTo 0
' 若因合併儲存格導致無法讀取欄數，改用計算第一列的儲存格數
If colCount = 0 Then colCount = tbl.Rows(1).Cells.Count
End If
' 4. 關閉範本 (不存檔)
wdDoc.Close SaveChanges:=False
' 這裡不要 Quit Word，因為等一下副程式還要用，保留著比較快
Application.StatusBar = False
' 5. 根據表格結構進行決策
' -------------------------------------------------------
' 條件 A：2欄 * 2列 -> 執行名牌模式 (依序填入)
' -------------------------------------------------------
If rowCount = 2 And colCount = 2 Then
modeName = "名牌模式 (2x2)"
If MsgBox("偵測到範本為 [2欄 x 2列]。" & vbCrLf & _
"將執行 [" & modeName & "]，是否繼續？", vbQuestion + vbYesNo) = vbYes Then
' 呼叫名牌模式副程式
Call ExecuteNameTag_Seq_2x2
End If
' -------------------------------------------------------
' 條件 B：其他狀況 (例如 1欄5列, 1欄1列) -> 執行桌牌模式 (單檔處理)
' -------------------------------------------------------
Else
modeName = "桌牌模式 (一般套印)"
modeName2 = Sheets("設定頁面").Range("B5").Value
If MsgBox("偵測到範本為 [" & colCount & "欄 x " & rowCount & "列]。" & vbCrLf & _
"將執行 [" & modeName & "]，是否繼續？", vbQuestion + vbYesNo) = vbYes Then
If modeName2 = "單獨" Then
' 呼叫桌牌模式副程式 (不合併版)
Call ExecuteImageReplacement_Separate_AutoRotate
Else
' 如果您桌牌想改用「合併版」，請改呼叫下面這行：
Call ExecuteDeskTag_1x5_WIA_Flip
End If
End If
End If
' 釋放物件
Set tbl = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
' ==============================================================================
' 按鈕 3：智慧總執行按鈕 (Auto-Detect Master Controller)
' 功能：自動判斷 Word 範本表格結構，決定跑哪種模式
' ==============================================================================
Sub MasterExecute_Smart()
Dim templatePath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rowCount As Long, colCount As Long
Dim modeName As String
Dim modeName2 As String
' 1. 檢查範本路徑
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
' 2. 背景啟動 Word 進行偵測
Application.StatusBar = "正在偵測範本格式..."
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = False ' 偵測時不顯示，以免畫面閃爍
' 3. 開啟範本讀取表格資訊
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
' 預設值
rowCount = 0
colCount = 0
If wdDoc.Tables.Count >= 1 Then
Set tbl = wdDoc.Tables(1)
' 取得列數與欄數
' 注意：若表格有合併儲存格，Columns.Count 可能會報錯，故加強防護
On Error Resume Next
rowCount = tbl.Rows.Count
colCount = tbl.Columns.Count
On Error GoTo 0
' 若因合併儲存格導致無法讀取欄數，改用計算第一列的儲存格數
If colCount = 0 Then colCount = tbl.Rows(1).Cells.Count
End If
' 4. 關閉範本 (不存檔)
wdDoc.Close SaveChanges:=False
' 這裡不要 Quit Word，因為等一下副程式還要用，保留著比較快
Application.StatusBar = False
' 5. 根據表格結構進行決策
' -------------------------------------------------------
' 條件 A：2欄 * 2列 -> 執行名牌模式 (依序填入)
' -------------------------------------------------------
If rowCount = 2 And colCount = 2 Then
modeName = "名牌模式 (2x2)"
If MsgBox("偵測到範本為 [2欄 x 2列]。" & vbCrLf & _
"將執行 [" & modeName & "]，是否繼續？", vbQuestion + vbYesNo) = vbYes Then
' 呼叫名牌模式副程式
Call ExecuteNameTag_Seq_2x2
End If
' -------------------------------------------------------
' 條件 B：其他狀況 (例如 1欄5列, 1欄1列) -> 執行桌牌模式 (單檔處理)
' -------------------------------------------------------
Else
modeName = "桌牌模式 (一般套印)"
modeName2 = Sheets("設定頁面").Range("B5").Value
If MsgBox("偵測到範本為 [" & colCount & "欄 x " & rowCount & "列]。" & vbCrLf & _
"將執行 [" & modeName & "]，是否繼續？", vbQuestion + vbYesNo) = vbYes Then
If modeName2 = "單獨" Then
' 呼叫桌牌模式副程式 (不合併版)
Call ExecuteImageReplacement_Separate_AutoRotate
Else
' 如果您桌牌想改用「合併版」，請改呼叫下面這行：
Call ExecuteDeskTag_1x5_WIA_Flip
End If
End If
End If
' 釋放物件
Set tbl = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
1.名牌
比較單純的1頁插入4張圖片，套用範本圖檔的寬高設定
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
' ******************************************************************************
' 邏輯 A：[名牌模式] 2x2 依序填入 (修改版：繼承範本圖片尺寸)
' ******************************************************************************
Sub ExecuteNameTag_Seq_2x2()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rng As Object, cellRange As Object, newInlineShp As Object
Dim cellIndex As Integer
' 新增變數：用來記住範本圖片的尺寸
Dim targetWidth As Single, targetHeight As Single
Dim hasPlaceholder As Boolean
' --- 1. 檢查路徑 ---
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
' --- 2. 啟動 Word ---
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "正在製作名牌..."
' --- 3. 初始化文件 ---
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
wdDoc.SaveAs2 outputFolder & "NameTag_Result.docx"
' --- 4. 迴圈填入圖片 ---
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
' 計算目前圖片應該在第幾格 (1~4)
cellIndex = ((i - 2) Mod 4) + 1
' 如果是新的一頁的第一格 (且不是第一張圖)，插入新的一頁範本
If cellIndex = 1 And i > 2 Then
Set rng = wdDoc.Range
rng.Collapse Direction:=0 ' wdCollapseEnd
rng.InsertBreak Type:=2 ' 分節符號(下一頁)
rng.InsertFile fileName:=templatePath, Link:=False, Attachment:=False
End If
' 鎖定「最後一個表格」
If wdDoc.Tables.Count > 0 Then
Set tbl = wdDoc.Tables(wdDoc.Tables.Count)
If tbl.Range.Cells.Count >= 4 Then
Set cellRange = tbl.Range.Cells(cellIndex).Range
' === [關鍵修改點] 開始 ===
hasPlaceholder = False
' 1. 檢查格子裡有沒有範本圖 (Placeholder)
If cellRange.InlineShapes.Count > 0 Then
' 2. 記住它的寬高
targetWidth = cellRange.InlineShapes(1).Width
targetHeight = cellRange.InlineShapes(1).Height
hasPlaceholder = True
' 3. 刪除範本圖
cellRange.InlineShapes(1).Delete
End If
' 4. 插入新圖片
If Dir(imgPath) <> "" Then
Set newInlineShp = wdDoc.InlineShapes.AddPicture( _
fileName:=imgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=cellRange)
' 5. 套用尺寸 (保持比例版)
If hasPlaceholder Then
newInlineShp.LockAspectRatio = -1 ' msoTrue (保持比例)
' 先對齊寬度
newInlineShp.Width = targetWidth
' 如果高度爆框，就改對齊高度
If newInlineShp.Height > targetHeight Then
newInlineShp.Height = targetHeight
End If
Else
' 如果原本沒圖，就改用自動縮放 (原本的備案)
ResizeImageToFitCell newInlineShp, tbl.Range.Cells(cellIndex)
End If
End If
' === [關鍵修改點] 結束 ===
End If
End If
If i Mod 20 = 0 Then wdDoc.Save
Next i
wdDoc.Save
MsgBox "名牌製作完成！" & vbCrLf & "檔案位於：" & outputFolder & "NameTag_Result.docx", vbInformation
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
End Sub
' 邏輯 A：[名牌模式] 2x2 依序填入 (修改版：繼承範本圖片尺寸)
' ******************************************************************************
Sub ExecuteNameTag_Seq_2x2()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rng As Object, cellRange As Object, newInlineShp As Object
Dim cellIndex As Integer
' 新增變數：用來記住範本圖片的尺寸
Dim targetWidth As Single, targetHeight As Single
Dim hasPlaceholder As Boolean
' --- 1. 檢查路徑 ---
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
' --- 2. 啟動 Word ---
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "正在製作名牌..."
' --- 3. 初始化文件 ---
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
wdDoc.SaveAs2 outputFolder & "NameTag_Result.docx"
' --- 4. 迴圈填入圖片 ---
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
' 計算目前圖片應該在第幾格 (1~4)
cellIndex = ((i - 2) Mod 4) + 1
' 如果是新的一頁的第一格 (且不是第一張圖)，插入新的一頁範本
If cellIndex = 1 And i > 2 Then
Set rng = wdDoc.Range
rng.Collapse Direction:=0 ' wdCollapseEnd
rng.InsertBreak Type:=2 ' 分節符號(下一頁)
rng.InsertFile fileName:=templatePath, Link:=False, Attachment:=False
End If
' 鎖定「最後一個表格」
If wdDoc.Tables.Count > 0 Then
Set tbl = wdDoc.Tables(wdDoc.Tables.Count)
If tbl.Range.Cells.Count >= 4 Then
Set cellRange = tbl.Range.Cells(cellIndex).Range
' === [關鍵修改點] 開始 ===
hasPlaceholder = False
' 1. 檢查格子裡有沒有範本圖 (Placeholder)
If cellRange.InlineShapes.Count > 0 Then
' 2. 記住它的寬高
targetWidth = cellRange.InlineShapes(1).Width
targetHeight = cellRange.InlineShapes(1).Height
hasPlaceholder = True
' 3. 刪除範本圖
cellRange.InlineShapes(1).Delete
End If
' 4. 插入新圖片
If Dir(imgPath) <> "" Then
Set newInlineShp = wdDoc.InlineShapes.AddPicture( _
fileName:=imgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=cellRange)
' 5. 套用尺寸 (保持比例版)
If hasPlaceholder Then
newInlineShp.LockAspectRatio = -1 ' msoTrue (保持比例)
' 先對齊寬度
newInlineShp.Width = targetWidth
' 如果高度爆框，就改對齊高度
If newInlineShp.Height > targetHeight Then
newInlineShp.Height = targetHeight
End If
Else
' 如果原本沒圖，就改用自動縮放 (原本的備案)
ResizeImageToFitCell newInlineShp, tbl.Range.Cells(cellIndex)
End If
End If
' === [關鍵修改點] 結束 ===
End If
End If
If i Mod 20 = 0 Then wdDoc.Save
Next i
wdDoc.Save
MsgBox "名牌製作完成！" & vbCrLf & "檔案位於：" & outputFolder & "NameTag_Result.docx", vbInformation
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
End Sub
副程式處理圖檔的尺寸設定
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
' 輔助：將圖片調整大小以適應儲存格 (保留邊距)
Sub ResizeImageToFitCell(shp As Object, cell As Object)
Dim cellWidth As Single, cellHeight As Single
Dim ratio As Single
' 取得儲存格可用寬度 (扣除左右邊界)
cellWidth = cell.Width - cell.LeftPadding - cell.RightPadding
' 高度比較難抓準，先用寬度做基準，通常名牌寬度是限制
shp.LockAspectRatio = -1 ' msoTrue
' 如果圖片比格子寬，就縮小
If shp.Width > cellWidth Then
shp.Width = cellWidth
End If
' 置中對齊
shp.Range.ParagraphFormat.Alignment = 1 ' wdAlignParagraphCenter
End Sub
Sub ResizeImageToFitCell(shp As Object, cell As Object)
Dim cellWidth As Single, cellHeight As Single
Dim ratio As Single
' 取得儲存格可用寬度 (扣除左右邊界)
cellWidth = cell.Width - cell.LeftPadding - cell.RightPadding
' 高度比較難抓準，先用寬度做基準，通常名牌寬度是限制
shp.LockAspectRatio = -1 ' msoTrue
' 如果圖片比格子寬，就縮小
If shp.Width > cellWidth Then
shp.Width = cellWidth
End If
' 置中對齊
shp.Range.ParagraphFormat.Alignment = 1 ' wdAlignParagraphCenter
End Sub
2.桌牌
1*5的表格，中間欄位是為了對折而留空的，頭尾的欄位是留著用來往內折，方便立起來
圖檔會是在第2格與第4格欄位，其中有一張需要旋轉180度，會透過副程式來製作
合併模式
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
' ******************************************************************************
' 邏輯 B (WIA 翻轉版)：[桌牌模式] 1頁1筆資料
' 1. 圖片插入第2格(翻轉) 與 第4格(正常)
' 2. 使用 WIA 建立暫存翻轉圖檔，確保 Word 排版穩定
' ******************************************************************************
Sub ExecuteDeskTag_1x5_WIA_Flip()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String, finalImgPath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rng As Object, cellRange As Object, newInlineShp As Object
' 用來控制要插入圖片的格子
Dim targetCells As Variant
Dim cellIndex As Variant
' 用來記住範本圖片的尺寸
Dim targetWidth As Single, targetHeight As Single
Dim hasPlaceholder As Boolean
Dim isTempFile As Boolean ' 標記是否為暫存檔
' --- 1. 檢查路徑 ---
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
' --- 2. 啟動 Word ---
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "正在製作桌牌 (WIA翻轉模式)..."
' --- 3. 初始化文件 ---
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
wdDoc.SaveAs2 outputFolder & "DeskTag_Final.docx"
' 設定目標格子：第2格(翻轉) 和 第4格(正常)
targetCells = Array(2, 4)
' --- 4. 迴圈填入圖片 ---
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
' [換頁邏輯]
If i > 2 Then
Set rng = wdDoc.Range
rng.Collapse Direction:=0 ' wdCollapseEnd
rng.InsertBreak Type:=2 ' 分節符號(下一頁)
rng.InsertFile fileName:=templatePath, Link:=False, Attachment:=False
End If
' 鎖定「最後一個表格」
If wdDoc.Tables.Count > 0 Then
Set tbl = wdDoc.Tables(wdDoc.Tables.Count)
For Each cellIndex In targetCells
If tbl.Range.Cells.Count >= cellIndex Then
Set cellRange = tbl.Range.Cells(cellIndex).Range
' === 決定使用哪張圖 ===
isTempFile = False
If cellIndex = 2 Then
' 第2格：產生旋轉暫存圖
finalImgPath = CreateRotatedTempImage(imgPath)
isTempFile = True
Else
' 第4格：使用原圖
finalImgPath = imgPath
End If
' === 圖片處理標準流程 ===
hasPlaceholder = False
' 1. 偵測範本圖尺寸 (支援嵌入式與浮動式)
If cellRange.InlineShapes.Count > 0 Then
targetWidth = cellRange.InlineShapes(1).Width
targetHeight = cellRange.InlineShapes(1).Height
hasPlaceholder = True
cellRange.InlineShapes(1).Delete
ElseIf cellRange.ShapeRange.Count > 0 Then
targetWidth = cellRange.ShapeRange(1).Width
targetHeight = cellRange.ShapeRange(1).Height
hasPlaceholder = True
cellRange.ShapeRange(1).Delete
End If
' 2. 插入新圖片 (都是 InlineShape，穩定！)
If Dir(finalImgPath) <> "" Then
Set newInlineShp = wdDoc.InlineShapes.AddPicture( _
fileName:=finalImgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=cellRange)
' 3. 套用尺寸
If hasPlaceholder Then
newInlineShp.LockAspectRatio = -1 ' msoTrue
newInlineShp.Width = targetWidth
If newInlineShp.Height > targetHeight Then
newInlineShp.Height = targetHeight
End If
End If
' 4. 如果是暫存檔，插入完畢後立刻刪除
If isTempFile Then
On Error Resume Next
Kill finalImgPath
On Error GoTo 0
End If
End If
End If
Next cellIndex
End If
If i Mod 10 = 0 Then wdDoc.Save
Next i
' --- 5. 完成 ---
wdDoc.Save
MsgBox "桌牌製作完成！" & vbCrLf & "檔案位於：" & outputFolder & "DeskTag_Final.docx", vbInformation
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
End Sub
' 邏輯 B (WIA 翻轉版)：[桌牌模式] 1頁1筆資料
' 1. 圖片插入第2格(翻轉) 與 第4格(正常)
' 2. 使用 WIA 建立暫存翻轉圖檔，確保 Word 排版穩定
' ******************************************************************************
Sub ExecuteDeskTag_1x5_WIA_Flip()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String, finalImgPath As String
Dim wdApp As Object, wdDoc As Object, tbl As Object
Dim rng As Object, cellRange As Object, newInlineShp As Object
' 用來控制要插入圖片的格子
Dim targetCells As Variant
Dim cellIndex As Variant
' 用來記住範本圖片的尺寸
Dim targetWidth As Single, targetHeight As Single
Dim hasPlaceholder As Boolean
Dim isTempFile As Boolean ' 標記是否為暫存檔
' --- 1. 檢查路徑 ---
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
' --- 2. 啟動 Word ---
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "正在製作桌牌 (WIA翻轉模式)..."
' --- 3. 初始化文件 ---
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
wdDoc.SaveAs2 outputFolder & "DeskTag_Final.docx"
' 設定目標格子：第2格(翻轉) 和 第4格(正常)
targetCells = Array(2, 4)
' --- 4. 迴圈填入圖片 ---
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
' [換頁邏輯]
If i > 2 Then
Set rng = wdDoc.Range
rng.Collapse Direction:=0 ' wdCollapseEnd
rng.InsertBreak Type:=2 ' 分節符號(下一頁)
rng.InsertFile fileName:=templatePath, Link:=False, Attachment:=False
End If
' 鎖定「最後一個表格」
If wdDoc.Tables.Count > 0 Then
Set tbl = wdDoc.Tables(wdDoc.Tables.Count)
For Each cellIndex In targetCells
If tbl.Range.Cells.Count >= cellIndex Then
Set cellRange = tbl.Range.Cells(cellIndex).Range
' === 決定使用哪張圖 ===
isTempFile = False
If cellIndex = 2 Then
' 第2格：產生旋轉暫存圖
finalImgPath = CreateRotatedTempImage(imgPath)
isTempFile = True
Else
' 第4格：使用原圖
finalImgPath = imgPath
End If
' === 圖片處理標準流程 ===
hasPlaceholder = False
' 1. 偵測範本圖尺寸 (支援嵌入式與浮動式)
If cellRange.InlineShapes.Count > 0 Then
targetWidth = cellRange.InlineShapes(1).Width
targetHeight = cellRange.InlineShapes(1).Height
hasPlaceholder = True
cellRange.InlineShapes(1).Delete
ElseIf cellRange.ShapeRange.Count > 0 Then
targetWidth = cellRange.ShapeRange(1).Width
targetHeight = cellRange.ShapeRange(1).Height
hasPlaceholder = True
cellRange.ShapeRange(1).Delete
End If
' 2. 插入新圖片 (都是 InlineShape，穩定！)
If Dir(finalImgPath) <> "" Then
Set newInlineShp = wdDoc.InlineShapes.AddPicture( _
fileName:=finalImgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=cellRange)
' 3. 套用尺寸
If hasPlaceholder Then
newInlineShp.LockAspectRatio = -1 ' msoTrue
newInlineShp.Width = targetWidth
If newInlineShp.Height > targetHeight Then
newInlineShp.Height = targetHeight
End If
End If
' 4. 如果是暫存檔，插入完畢後立刻刪除
If isTempFile Then
On Error Resume Next
Kill finalImgPath
On Error GoTo 0
End If
End If
End If
Next cellIndex
End If
If i Mod 10 = 0 Then wdDoc.Save
Next i
' --- 5. 完成 ---
wdDoc.Save
MsgBox "桌牌製作完成！" & vbCrLf & "檔案位於：" & outputFolder & "DeskTag_Final.docx", vbInformation
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
End Sub
副程式
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
' 桌牌模式用的旋轉輔助函數
Function CreateRotatedTempImage(srcPath As String) As String
Dim ImgObj As Object, IP As Object, tempPath As String
tempPath = Sheets("設定頁面").Range("B3").Value & "Output\TEMP_" & Format(Now, "hhmmss_ms") & ".jpg"
Set ImgObj = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
On Error Resume Next
ImgObj.LoadFile srcPath
If Err.Number <> 0 Then CreateRotatedTempImage = srcPath: Exit Function
On Error GoTo 0
IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
IP.Filters(1).Properties("RotationAngle") = 180
Set ImgObj = IP.Apply(ImgObj)
If Dir(tempPath) <> "" Then Kill tempPath
ImgObj.SaveFile tempPath
CreateRotatedTempImage = tempPath
End Function
Function CreateRotatedTempImage(srcPath As String) As String
Dim ImgObj As Object, IP As Object, tempPath As String
tempPath = Sheets("設定頁面").Range("B3").Value & "Output\TEMP_" & Format(Now, "hhmmss_ms") & ".jpg"
Set ImgObj = CreateObject("WIA.ImageFile")
Set IP = CreateObject("WIA.ImageProcess")
On Error Resume Next
ImgObj.LoadFile srcPath
If Err.Number <> 0 Then CreateRotatedTempImage = srcPath: Exit Function
On Error GoTo 0
IP.Filters.Add IP.FilterInfos("RotateFlip").FilterID
IP.Filters(1).Properties("RotationAngle") = 180
Set ImgObj = IP.Apply(ImgObj)
If Dir(tempPath) <> "" Then Kill tempPath
ImgObj.SaveFile tempPath
CreateRotatedTempImage = tempPath
End Function
單獨模式
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
' ******************************************************************************
' 邏輯 B：[桌牌模式] 原本的邏輯 (不合併版，含自動旋轉)
' ******************************************************************************
Sub ExecuteImageReplacement_Separate_AutoRotate()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String, imgName As String
Dim wdApp As Object, wdDoc As Object
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "準備開始處理..."
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
imgName = wsList.Cells(i, 2).Value
Application.StatusBar = "正在處理: " & (i - 1) & " / " & (lastRow - 1) & " - " & imgName
If Dir(imgPath) <> "" Then
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
' 呼叫副程式
ProcessSingleDoc wdDoc, imgPath
wdDoc.SaveAs2 outputFolder & imgName & ".docx"
wdDoc.Close SaveChanges:=False
End If
Next i
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
MsgBox "桌牌製作完成！(個別檔案)", vbInformation
End Sub
' 邏輯 B：[桌牌模式] 原本的邏輯 (不合併版，含自動旋轉)
' ******************************************************************************
Sub ExecuteImageReplacement_Separate_AutoRotate()
Dim templatePath As String, outputFolder As String
Dim wsList As Worksheet
Dim lastRow As Long, i As Long
Dim imgPath As String, imgName As String
Dim wdApp As Object, wdDoc As Object
templatePath = Sheets("設定頁面").Range("B2").Value
If Dir(templatePath) = "" Then MsgBox "找不到 Word 範本！", vbCritical: Exit Sub
Set wsList = Sheets("圖檔清單")
lastRow = wsList.Cells(wsList.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then MsgBox "圖檔清單為空！", vbExclamation: Exit Sub
outputFolder = Sheets("設定頁面").Range("B3").Value & "Output\"
If Dir(outputFolder, vbDirectory) = "" Then MkDir outputFolder
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
wdApp.Visible = True
Application.StatusBar = "準備開始處理..."
For i = 2 To lastRow
imgPath = wsList.Cells(i, 1).Value
imgName = wsList.Cells(i, 2).Value
Application.StatusBar = "正在處理: " & (i - 1) & " / " & (lastRow - 1) & " - " & imgName
If Dir(imgPath) <> "" Then
Set wdDoc = wdApp.Documents.Open(templatePath, ReadOnly:=True)
' 呼叫副程式
ProcessSingleDoc wdDoc, imgPath
wdDoc.SaveAs2 outputFolder & imgName & ".docx"
wdDoc.Close SaveChanges:=False
End If
Next i
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Application.StatusBar = False
MsgBox "桌牌製作完成！(個別檔案)", vbInformation
End Sub
副程式ProcessSingleDoc是用來處理圖檔
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
Sub ProcessSingleDoc(wdDoc As Object, imgPath As String)
Dim tbl As Object
Dim oldShp As Object, newInlineShp As Object
Dim anchorRange As Object, targetRange As Object
Dim oldWidth As Single, oldHeight As Single
Dim oldRotation As Single
Dim sIdx As Integer
Dim finalImgPath As String
Dim isTempFile As Boolean
If wdDoc.Tables.Count >= 1 Then
Set tbl = wdDoc.Tables(1)
' 1. 先處理 InlineShape
If tbl.Range.InlineShapes.Count > 0 Then
For sIdx = tbl.Range.InlineShapes.Count To 1 Step -1
Set oldShp = tbl.Range.InlineShapes(sIdx)
oldWidth = oldShp.Width
oldHeight = oldShp.Height
Set targetRange = oldShp.Range
oldShp.Delete
Set newInlineShp = wdDoc.InlineShapes.AddPicture(fileName:=imgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=targetRange)
newInlineShp.LockAspectRatio = 0
newInlineShp.Width = oldWidth
newInlineShp.Height = oldHeight
Next sIdx
End If
' 2. 再處理 Shape (含旋轉)
If tbl.Range.ShapeRange.Count > 0 Then
For sIdx = tbl.Range.ShapeRange.Count To 1 Step -1
Set oldShp = tbl.Range.ShapeRange(sIdx)
oldWidth = oldShp.Width
oldHeight = oldShp.Height
oldRotation = oldShp.Rotation
Set anchorRange = oldShp.Anchor
isTempFile = False
If oldRotation = 180 Or oldRotation = -180 Then
finalImgPath = CreateRotatedTempImage(imgPath)
isTempFile = True
Else
finalImgPath = imgPath
End If
oldShp.Delete
Set newInlineShp = wdDoc.InlineShapes.AddPicture(fileName:=finalImgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=anchorRange)
newInlineShp.LockAspectRatio = 0
newInlineShp.Width = oldWidth
newInlineShp.Height = oldHeight
If isTempFile Then
On Error Resume Next
Kill finalImgPath
On Error GoTo 0
End If
Next sIdx
End If
End If
End Sub
Dim tbl As Object
Dim oldShp As Object, newInlineShp As Object
Dim anchorRange As Object, targetRange As Object
Dim oldWidth As Single, oldHeight As Single
Dim oldRotation As Single
Dim sIdx As Integer
Dim finalImgPath As String
Dim isTempFile As Boolean
If wdDoc.Tables.Count >= 1 Then
Set tbl = wdDoc.Tables(1)
' 1. 先處理 InlineShape
If tbl.Range.InlineShapes.Count > 0 Then
For sIdx = tbl.Range.InlineShapes.Count To 1 Step -1
Set oldShp = tbl.Range.InlineShapes(sIdx)
oldWidth = oldShp.Width
oldHeight = oldShp.Height
Set targetRange = oldShp.Range
oldShp.Delete
Set newInlineShp = wdDoc.InlineShapes.AddPicture(fileName:=imgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=targetRange)
newInlineShp.LockAspectRatio = 0
newInlineShp.Width = oldWidth
newInlineShp.Height = oldHeight
Next sIdx
End If
' 2. 再處理 Shape (含旋轉)
If tbl.Range.ShapeRange.Count > 0 Then
For sIdx = tbl.Range.ShapeRange.Count To 1 Step -1
Set oldShp = tbl.Range.ShapeRange(sIdx)
oldWidth = oldShp.Width
oldHeight = oldShp.Height
oldRotation = oldShp.Rotation
Set anchorRange = oldShp.Anchor
isTempFile = False
If oldRotation = 180 Or oldRotation = -180 Then
finalImgPath = CreateRotatedTempImage(imgPath)
isTempFile = True
Else
finalImgPath = imgPath
End If
oldShp.Delete
Set newInlineShp = wdDoc.InlineShapes.AddPicture(fileName:=finalImgPath, LinkToFile:=False, SaveWithDocument:=True, Range:=anchorRange)
newInlineShp.LockAspectRatio = 0
newInlineShp.Width = oldWidth
newInlineShp.Height = oldHeight
If isTempFile Then
On Error Resume Next
Kill finalImgPath
On Error GoTo 0
End If
Next sIdx
End If
End If
End Sub
後記
由於程式碼是分好幾次由Gemini產生，再透過測試與修正而成的
程式碼看起來會很臃腫跟重複，之後也要精進自己使用AI的能力
0 comments:
張貼留言