Excel/Word VBA寫過不少,頭一次寫PowerPoint VBA,拿出來分享一下。

同事跟我分享了多年來的收藏--一大堆精美華麗的投影片範例,需要對長官高層做簡報時,找相近的改一改,唬人效果十足。不過一百多個PPT檔案每個都只有一張投影片(因為背景、樣版不同,難以合併),瀏覽起來頗為麻煩!

為了感謝同事的慷慨分享,我寫了以下VBA作為回報。這段程式,會逐一列出Slides子目錄下的所有PPT檔,對每一張投影片產生縮圖,然後以一張投影片四張縮圖的方式排版,再為縮圖加上超連結以便開啟原投影片檔案,便做成了方便瀏覽檢閱的索引型錄囉!

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

產生的索引PPT如上圖所示,在縮圖上按右鍵再選"開啟超連結"就可以打開投影片來源檔案。有需要的朋友請自取參考。


Comments

# by Leonboy

謝謝大大的分享, 對我們作專案的人很受用, 對我好似無法直接套用在 PPT 2007 中, 請問除了一些 COM object 要作 reference, 還要注意那些? 謝謝解答 ^^

# by Jeffrey

to Leonboy, 文中的程式碼是寫在PPT2007的VBA,不過因為使用Early-Binding方式呼叫Scripting.FileSystemObject,在專案裡要參照"Microsoft Scripting Runtime" (scrrun.dll)。

# by Yangjie

Excel 用VBA將**.jpg 像素縮小並另存新檔 可否指導 不勝感激

# by Jeffrey

to Yangjie, 在VBA要將JPG檔轉為縮圖,我認為借助第三方元件會是最簡便的做法,不過VBA領域我涉獵不多,抱歉無法提供更具體建議。另一個思考方向是,借用.NET的圖檔處理功能自行寫個小函數再包成COM+供VBA呼叫,也是種解法。

Post a comment


40 - 16 =