AI神救援！PowerPoint自動化批量匯入圖片，數百張投影片一次完成

為了提供學生自主學習 18 週計畫的資訊圖表範例，最近花了一些時間製作了 2000 張資訊圖表，並打算每 200 張彙整成一份 PowerPoint 簡報檔，一共要做 20 個檔案。若是逐張將圖片插入投影片，至少得拖曳 2000 次，實在不是件輕鬆的工作。這時候，我心想，正是該讓 AI 上場救援了。（本例不採用 PowerPoint 的新增相簿功能）

先在一個資料夾中準備好 200 張資訊圖表，這些資訊圖表的規格完全相同。因為每次只處理 200 張圖，所以，2000 張資訊圖表要分 10 次處理。

參考作法

2.請 ChatGPT 產生一個 VBA 程式來執行這個工作。

提示詞：我需要將一個資料夾中的200張圖片放入一個PowerPoint檔案中，每一張投影片放入一張圖片，圖片以等比例縮放插入投影片中，請為這個工作提供可以讓PowerPoint使用的VBA程式。

3.複製 ChatGPT 提供的程式碼。（完整程式碼在文章最後）

4.在 PowerPoint 中使用快速鍵： Alt + F11，以進入 VBA 編輯器。

5.點選功能表：插入/模組，貼上先前複製的程式碼。

6.回到 PowerPoint 中，使用快速鍵：Alt + F8，選取巨集指令（本例：ImportPictures_OnePerSlide），再點選：執行。

7.接著，選取圖片放置的資料夾。點選：確定，資料夾中的圖片就會自動匯入。（速度算很快了）

最後存檔時，PowerPoint 會告知儲存檔案時，無法儲存這個巨集指令。點選：是。

ChatGPT 提供的 VBA 完整程式

Option Explicit

' ====== 入口：選資料夾後匯入，每張圖一張投影片 ======
Public Sub ImportPictures_OnePerSlide()
    Dim folderPath As String
    folderPath = PickFolder()
    If folderPath = "" Then Exit Sub
    
    Dim files As Collection
    Set files = GetImageFilesSorted(folderPath)
    
    If files.Count = 0 Then
        MsgBox "此資料夾找不到圖片檔（jpg/png/gif/bmp/tif/webp）。", vbExclamation
        Exit Sub
    End If
    
    Dim pres As Presentation
    Set pres = ActivePresentation
    
    Dim i As Long
    For i = 1 To files.Count
        Dim sld As Slide
        Set sld = pres.Slides.Add(pres.Slides.Count + 1, ppLayoutBlank)
        
        Dim shp As Shape
        Set shp = sld.Shapes.AddPicture( _
            FileName:=CStr(files(i)), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=0, Top:=0, Width:=-1, Height:=-1)
        
        ' 你可以二選一：
        FitPictureContain shp, sld    ' 完整顯示(不裁切)，等比例縮放置中（推薦）
        'FitPictureCover shp, sld     ' 滿版填滿(會裁切)，等比例縮放後裁切置中
    Next i
    
    MsgBox "完成！已匯入 " & files.Count & " 張圖片。", vbInformation
End Sub

' ====== 等比例縮放：完整顯示(Contain)，不裁切，置中 ======
Private Sub FitPictureContain(ByVal pic As Shape, ByVal sld As Slide)
    Dim sw As Single, sh As Single
    sw = sld.Parent.PageSetup.SlideWidth
    sh = sld.Parent.PageSetup.SlideHeight
    
    pic.LockAspectRatio = msoTrue
    
    ' 先以寬為基準
    pic.Width = sw
    ' 若高度超出，改以高為基準
    If pic.Height > sh Then
        pic.Height = sh
    End If
    
    pic.Left = (sw - pic.Width) / 2
    pic.Top = (sh - pic.Height) / 2
End Sub

' ====== 等比例縮放：滿版填滿(Cover)，會裁切，置中 ======
Private Sub FitPictureCover(ByVal pic As Shape, ByVal sld As Slide)
    Dim sw As Single, sh As Single
    sw = sld.Parent.PageSetup.SlideWidth
    sh = sld.Parent.PageSetup.SlideHeight
    
    pic.LockAspectRatio = msoTrue
    
    ' 先以寬填滿
    pic.Width = sw
    ' 若高度不足，改以高填滿
    If pic.Height < sh Then
        pic.Height = sh
    End If
    
    pic.Left = (sw - pic.Width) / 2
    pic.Top = (sh - pic.Height) / 2
    
    ' 裁切到投影片大小
    With pic.PictureFormat.Crop
        .Left = IIf(pic.Width > sw, (pic.Width - sw) / 2, 0)
        .Right = IIf(pic.Width > sw, (pic.Width - sw) / 2, 0)
        .Top = IIf(pic.Height > sh, (pic.Height - sh) / 2, 0)
        .Bottom = IIf(pic.Height > sh, (pic.Height - sh) / 2, 0)
    End With
    
    pic.Left = 0
    pic.Top = 0
    pic.Width = sw
    pic.Height = sh
End Sub

' ====== 取得資料夾內圖片檔（依檔名排序） ======
Private Function GetImageFilesSorted(ByVal folderPath As String) As Collection
    Dim col As New Collection
    
    Dim fso As Object, folder As Object, file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 收集圖片檔
    For Each file In folder.Files
        Dim ext As String
        ext = LCase$(fso.GetExtensionName(file.Name))
        
        If ext = "jpg" Or ext = "jpeg" Or ext = "png" Or ext = "gif" Or _
           ext = "bmp" Or ext = "tif" Or ext = "tiff" Or ext = "webp" Then
            col.Add file.Path
        End If
    Next file
    
    ' 轉陣列排序（字典序）
    Dim arr() As String
    Dim i As Long
    If col.Count > 0 Then
        ReDim arr(1 To col.Count)
        For i = 1 To col.Count
            arr(i) = CStr(col(i))
        Next i
        QuickSortStrings arr, LBound(arr), UBound(arr)
        
        Dim sorted As New Collection
        For i = LBound(arr) To UBound(arr)
            sorted.Add arr(i)
        Next i
        Set GetImageFilesSorted = sorted
    Else
        Set GetImageFilesSorted = col
    End If
End Function

' ====== 字串 QuickSort（檔名排序用） ======
Private Sub QuickSortStrings(ByRef arr() As String, ByVal first As Long, ByVal last As Long)
    Dim i As Long, j As Long
    Dim pivot As String, tmp As String
    
    i = first
    j = last
    pivot = arr((first + last) \ 2)
    
    Do While i <= j
        Do While arr(i) < pivot: i = i + 1: Loop
        Do While arr(j) > pivot: j = j - 1: Loop
        If i <= j Then
            tmp = arr(i)
            arr(i) = arr(j)
            arr(j) = tmp
            i = i + 1
            j = j - 1
        End If
    Loop
    
    If first < j Then QuickSortStrings arr, first, j
    If i < last Then QuickSortStrings arr, i, last
End Sub

' ====== 選資料夾（Windows / Office 常用對話框） ======
Private Function PickFolder() As String
    On Error GoTo EH
    
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "請選擇圖片資料夾"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            PickFolder = ""
        Else
            PickFolder = .SelectedItems(1)
        End If
    End With
    Exit Function
    
EH:
    PickFolder = ""
End Function