VBA / Power point 使用VBA套印資料輸出桌牌/名牌 2

VBA / Power point 使用VBA套印資料輸出桌牌/名牌 2

Post Views: 17

前一篇文章完成了批次產生桌牌或名牌的圖檔

再來就是輸出了

由於辦公室的影印機可以輸出A4、A3跟B4

所以我用A4格式來設定

名牌，一張A4，2欄2列(2*2)的表格，4張圖

桌牌，一張A4，1欄5列(1*5)的表格，1張圖，用2次，其中一張翻轉180度

我先建立範本，再用VBA批次替換圖片

程式碼說明如下

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
 
' ******************************************************************************
'  邏輯 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

 

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
 
' ******************************************************************************
'  邏輯 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
 
' 桌牌模式用的旋轉輔助函數
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

 

 

 

Tags: