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