為了提供學生自主學習 18 週計畫的資訊圖表範例，最近花了一些時間製作了 2000 張資訊圖表，並打算每 200 張彙整成一份 PowerPoint 簡報檔，一共要做 20 個檔案。若是逐張將圖片插入投影片，至少得拖曳 2000 次，實在不是件輕鬆的工作。這時候，我心想，正是該讓 AI 上場救援了。（本例不採用 PowerPoint 的新增相簿功能）
先在一個資料夾中準備好 200 張資訊圖表，這些資訊圖表的規格完全相同。因為每次只處理 200 張圖，所以，2000 張資訊圖表要分 10 次處理。
參考作法
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
