AI又來救援！批次將多個PowerPoint檔的第1頁儲存為PNG圖檔

每一個學期課程結束時，我都必須完成一項既固定又繁重的工作：將數百位學生繳交的 PowerPoint 作品逐一開啟，並把每個檔案的第一頁另存為 PNG 圖檔。過去這項流程完全仰賴人工操作，不僅需要反覆點擊、切換檔案，還容易因疲勞而出錯，整體而言相當耗時又耗費心力。

如今透過 AI 工具的協助，這項原本高度重複且低效率的工作得以大幅優化。AI 能夠自動批次處理檔案、快速擷取指定頁面並轉換成圖檔，使整個流程更加流暢且穩定。相較於以往，實際花費的時間與人工作業步驟都顯著減少，讓我能將更多心力投入在教學回饋與課程優化等更具價值的工作上。

複製這段程式碼（ChatGPT 產生的 VBA 程式碼放在文章最末）。

接著，準備好這上百個 PowerPoint 檔：

接著，開啟一個全新的 PowerPoint 檔，使用快速鍵： Alt + F11，以進入 VBA 編輯器。

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

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

選取 PowerPoint 所在的資料夾，再選取圖檔要儲存的資料夾。

2 分鐘的時間就做完幾個小時要做的事，真的是省時又力。太感謝 AI 啦！真是教師的好幫手。

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