CODE-自動產生投影片縮圖索引的PowerPoint VBA

Option Explicit

Sub BuildIndex()

    'FileSystemObject物件

    Dim FSO As Scripting.FileSystemObject

    Set FSO = New Scripting.FileSystemObject

    '取得現有路徑及暫存路徑

    Dim sCurrentPath As String, sTempPath As String

    sCurrentPath = ActivePresentation.Path

    sTempPath = FSO.GetSpecialFolder(TemporaryFolder)

    '索引PPT及標的PPT物件

    Dim pptIndex As Presentation, pptToOpen As Presentation

    Set pptIndex = ActivePresentation

    '一些工作用變數

    Dim I As Integer, S As Slide, ImgFile As String

    Dim iGlobalIndex As Integer, iIndexPerPage As Integer

    Dim iPngWidth As Integer, iPngHeight As Integer

    Dim sldIndex As Slide, picInserted As Shape

    Dim iDimCount As Integer, iIndexAtPage As Integer

    '先將有投影片清除，只留下最後一張，並清除其內容

    While pptIndex.Slides.Count > 1

        pptIndex.Slides(1).Delete

    Wend

    Set sldIndex = pptIndex.Slides(1)

    While (sldIndex.Shapes.Count > 0)

        sldIndex.Shapes(1).Delete

    Wend

    '複雜空白頁配置供後續新增時使用

    Dim pptLayout As CustomLayout

    Set pptLayout = pptIndex.Slides(1).CustomLayout

    iIndexPerPage = 4

    iDimCount = iIndexPerPage ^ 0.5

    iPngWidth = pptIndex.PageSetup.SlideWidth / iDimCount

    iPngHeight = pptIndex.PageSetup.SlideHeight / iDimCount

    iGlobalIndex = 0

    '列出待處理PPT的目錄及檔案物件

    Dim SourceFolder As Scripting.Folder

    Dim FileItem As Scripting.File

    '列舉檔案清單

    Set SourceFolder = FSO.GetFolder(sCurrentPath & "\Slides")

    For Each FileItem In SourceFolder.Files

        '排除索引PPT本身

        If InStr(LCase(FileItem.Name), "index") = 0 Then

            '開啟檔案

                Set pptToOpen = Presentations.Open(FileItem.Path, WithWindow:=msoFalse)

            I = 0

            ImgFile = sTempPath & "\" & Split(FileItem.Name, ".")(0) & "_" & I & ".png"

            For Each S In pptToOpen.Slides

                iIndexAtPage = iGlobalIndex Mod iIndexPerPage

                '索引檔加入新投影片

                If (iIndexAtPage = 0) Then

                    Set sldIndex = pptIndex.Slides.AddSlide(pptIndex.Slides.Count, pptLayout)

                End If

                '將投影片匯出成暫存PNG

                S.Export ImgFile, FilterName:="PNG", _

                         ScaleWidth:=iPngWidth * 1.2, ScaleHeight:=iPngHeight * 1.2

                '插入圖片

                Set picInserted = sldIndex.Shapes.AddPicture(ImgFile, Linktofile:=msoFalse, _

                                  SaveWithDocument:=msoTrue, _

                                  Left:=(iIndexAtPage Mod iDimCount) * iPngWidth, _

                                  Top:=(iIndexAtPage \ iDimCount) * iPngHeight, _

                                  Width:=iPngWidth, Height:=iPngHeight)

                '加上連至PPT的超連結

                With picInserted.ActionSettings(ppMouseClick)

                    .Action = ppActionHyperlink

                    .Hyperlink.Address = FileItem.Name

                End With

                I = I + 1

                iGlobalIndex = iGlobalIndex + 1

            Next

            '關閉PPT檔，刪除暫存圖檔

            pptToOpen.Close

            FSO.DeleteFile ImgFile

        End If

    Next

    '儲存索引檔

    pptIndex.SaveCopyAs sCurrentPath & "\Slides\Index.ppt", _

                        ppSaveAsOpenXMLPresentation, msoFalse

End Sub