VBA / Excel 使用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

' ==========================================
' 按鈕 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
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

 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

' ==============================================================================
' ==============================================================================
' 按鈕 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
  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

 1
 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

  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

 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

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

 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

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