ivantsoi的個人書籤

簡報一次過修改：改淡化動畫、刪除音效、統一字體、刪除動畫、列出字型清單

「A改成淡化動畫」、「B刪除音效」、「C統一字體為微軟正黑體」、「D換字體但排除標楷體和TimesNewRoman」、「E刪除動畫」、「同時運行ABC」、「同時運行ABD(只排除標楷體)」、附：列出字型清單

如果你要一次過在所有投影片上的把動畫「A改成淡化動畫」，可運行以下VBA代碼：

Sub ChangeAnimationsToFadeOut()
    Dim oSlide As Slide
    Dim oEffect As Effect
    Dim oPresentation As Presentation

    Set oPresentation = ActivePresentation

    ' 遍歷每個幻燈片
    For Each oSlide In oPresentation.Slides
        ' 遍歷每個幻燈片上的動畫效果
        For Each oEffect In oSlide.TimeLine.MainSequence
            ' 將動畫效果更改為淡出效果
            oEffect.EffectType = msoAnimEffectFade
            ' 設置淡出效果的速度
            oEffect.Timing.Duration = 0.5
        Next oEffect
    Next oSlide
    ' MsgBox "所有動畫已淡出效果！"
End Sub

要運行此代碼，請按照以下步驟操作：

  1. 打開您要修改的PowerPoint簡報。
  2. 按下 Alt + F11 鍵，打開VBA編輯器。
  3. 在VBA編輯器中，單擊菜單中的 插入 > 模組，在新模組中粘貼上面的代碼。
  4. 按下 F5 鍵執行代碼，或者在VBA編輯器中單擊菜單中的 執行 > 執行Sub / UserForm。執行完畢後，代碼已無用。
  5. 退出VBA編輯器，儲存文件，選「是」儲存為無巨集的普通文件。

現在，您的簡報中的所有動畫效果都將更改為淡化效果。

如果你要的不是淡化效果，而是其他動畫效果，可以參考以下：

MsoAnimEffect 枚舉 （PowerPoint） | Microsoft Learn

如果你要在所有動畫的「B刪除音效」，可運行以下VBA代碼：

Sub MuteAllAnimationSounds()
    Dim sld As Slide
    Dim eff As Effect
    For Each sld In ActivePresentation.Slides
        For Each eff In sld.TimeLine.MainSequence
            ' 只針對有聲音的動畫設為無聲
            If eff.EffectInformation.SoundEffect.Type <> msoSoundNone Then
                eff.EffectInformation.SoundEffect.Type = msoSoundNone
            End If
        Next eff
    Next sld
    ' MsgBox "所有動畫聲音已設為靜音！"
End Sub

如果你要在所有頁面的「C統一字體」為微軟正黑體 (可自行修改)，可運行以下VBA代碼：

Sub ChangeAllFontsIncludingMasters()
    Dim slideItem As Slide
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim shapeItem As Shape
    
    On Error Resume Next ' 避免部分特殊物件屬性引發錯誤而中斷執行
    
    ' 1. 處理所有普通投影片頁面
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            ProcessShape shapeItem
        Next shapeItem
    Next slideItem
    
    ' 2. 處理所有投影片母片 (Slide Masters)
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            ProcessShape shapeItem
        Next shapeItem
        
        ' 3. 處理母片底下的所有版面配置 (Custom Layouts)
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                ProcessShape shapeItem
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' MsgBox "全簡報（包含頁面、母片與版面配置）字體已成功統一為微軟正黑體！", vbInformation, "完成"
End Sub

' 遞迴處理各種圖形物件的子程式
Private Sub ProcessShape(shp As Shape)
    Dim rowIdx As Long, colIdx As Long
    Dim subShape As Shape
    
    ' 處理組合圖形（Group）- 遞迴支援多層組合
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            ProcessShape subShape
        Next subShape
        
    ' 處理表格（Table）
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        SetFont .Cell(rowIdx, colIdx).Shape.TextFrame
                    End If
                Next colIdx
            Next rowIdx
        End With
        
    ' 處理一般文字方塊、圖案、預留位置 (Placeholder)
    ElseIf shp.HasTextFrame Then
        SetFont shp.TextFrame
    End If
End Sub

' 設定字體的輔助子程式（同時設定中、英與複雜文字屬性）
Private Sub SetFont(tf As TextFrame)
    Const TARGET_FONT As String = "微軟正黑體"
    
    If tf.HasText Then
        With tf.TextRange.Font
            .Name = TARGET_FONT             ' 西文/拉丁字體
            .NameFarEast = TARGET_FONT       ' 中文/東亞字體
            .NameComplexScript = TARGET_FONT ' 複雜語系字體
        End With
    End If
End Sub

如果你要在所有頁面的「D統一字體為微軟正黑體，但排除標楷體和Times New Roman」 (可自行修改)，可運行以下VBA代碼：

Sub ChangeAllFontsIncludingMasters()
    Dim slideItem As Slide
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim shapeItem As Shape
    
    On Error Resume Next
    
    ' 1. 處理所有普通投影片頁面
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            ProcessShape shapeItem, False
        Next shapeItem
    Next slideItem
    
    ' 2. 處理所有投影片母片 (Slide Masters)
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            ProcessShape shapeItem, True
        Next shapeItem
        
        ' 3. 處理母片底下的所有版面配置 (Custom Layouts)
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                ProcessShape shapeItem, True
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' MsgBox "字型已統一為微軟正黑體（排除清單除外，母版與繼承母版的標楷體保留）！", vbInformation, "完成"
End Sub

Private Sub ProcessShape(shp As Shape, isMaster As Boolean)
    Dim rowIdx As Long, colIdx As Long
    Dim subShape As Shape
    
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            ProcessShape subShape, isMaster
        Next subShape
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        SetFont .Cell(rowIdx, colIdx).Shape.TextFrame, isMaster
                    End If
                Next colIdx
            Next rowIdx
        End With
    ElseIf shp.HasTextFrame Then
        SetFont shp.TextFrame, isMaster
    End If
End Sub

Private Sub SetFont(tf As TextFrame, isMaster As Boolean)
    Const TARGET_FONT As String = "微軟正黑體"
    Dim EXCLUDE_FONTS As Variant
    EXCLUDE_FONTS = Array("標楷體", "DFKai-SB", "Times New Roman")
    
    If tf.HasText Then
        With tf.TextRange.Font
            ' 如果字型名稱是空字串 → 表示繼承母版 → 跳過
            If .Name = "" Or .NameFarEast = "" Or .NameComplexScript = "" Then Exit Sub
            
            ' 如果字型在排除清單 → 跳過
            If IsExcluded(.Name, EXCLUDE_FONTS) _
               Or IsExcluded(.NameFarEast, EXCLUDE_FONTS) _
               Or IsExcluded(.NameComplexScript, EXCLUDE_FONTS) Then
               Exit Sub
            End If
            
            ' 其他情況才替換
            .Name = TARGET_FONT
            .NameFarEast = TARGET_FONT
            .NameComplexScript = TARGET_FONT
        End With
    End If
End Sub

Private Function IsExcluded(fontName As String, excludeList As Variant) As Boolean
    Dim f As Variant
    For Each f In excludeList
        If InStr(1, fontName, f, vbTextCompare) > 0 Then
            IsExcluded = True
            Exit Function
        End If
    Next f
    IsExcluded = False
End Function

如果你要一次過在所有投影片上的「E刪除所有動畫」，可運行以下VBA代碼：

Sub DeleteAllAnimations()
    Dim oSlide As Slide
    Dim oShape As Shape
    For Each oSlide In ActivePresentation.Slides
        For Each oShape In oSlide.Shapes
            oShape.AnimationSettings.EntryEffect = ppEffectNone
            oShape.AnimationSettings.AdvanceMode = ppAdvanceModeMixed
            oShape.AnimationSettings.AdvanceMode = ppAdvanceMouseClick
        Next oShape
    Next oSlide
End Sub

一次過同時運行「A改淡化動畫+B刪除音效+C統一字體」三個巨集

Sub AllMacros()
    ' 依序呼叫三個巨集
    Call ChangeAnimationsToFadeOut
    Call MuteAllAnimationSounds
    Call ChangeAllFontsIncludingMasters
End Sub

Sub ChangeAnimationsToFadeOut()
    Dim oSlide As Slide
    Dim oEffect As Effect
    Dim oPresentation As Presentation

    Set oPresentation = ActivePresentation

    ' 遍歷每個幻燈片
    For Each oSlide In oPresentation.Slides
        ' 遍歷每個幻燈片上的動畫效果
        For Each oEffect In oSlide.TimeLine.MainSequence
            ' 將動畫效果更改為淡出效果
            oEffect.EffectType = msoAnimEffectFade
            ' 設置淡出效果的速度
            oEffect.Timing.Duration = 0.5
        Next oEffect
    Next oSlide
End Sub



Sub MuteAllAnimationSounds()
    Dim sld As Slide
    Dim eff As Effect
    For Each sld In ActivePresentation.Slides
        For Each eff In sld.TimeLine.MainSequence
            ' 只針對有聲音的動畫設為無聲
            If eff.EffectInformation.SoundEffect.Type <> msoSoundNone Then
                eff.EffectInformation.SoundEffect.Type = msoSoundNone
            End If
        Next eff
    Next sld
    ' MsgBox "所有動畫聲音已設為靜音！"
End Sub



Sub ChangeAllFontsIncludingMasters()
    Dim slideItem As Slide
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim shapeItem As Shape
    
    On Error Resume Next ' 避免部分特殊物件屬性引發錯誤而中斷執行
    
    ' 1. 處理所有普通投影片頁面
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            ProcessShape shapeItem
        Next shapeItem
    Next slideItem
    
    ' 2. 處理所有投影片母片 (Slide Masters)
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            ProcessShape shapeItem
        Next shapeItem
        
        ' 3. 處理母片底下的所有版面配置 (Custom Layouts)
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                ProcessShape shapeItem
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' MsgBox "全簡報（包含頁面、母片與版面配置）字體已成功統一為微軟正黑體！", vbInformation, "完成"
End Sub

' 遞迴處理各種圖形物件的子程式
Private Sub ProcessShape(shp As Shape)
    Dim rowIdx As Long, colIdx As Long
    Dim subShape As Shape
    
    ' 處理組合圖形（Group）- 遞迴支援多層組合
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            ProcessShape subShape
        Next subShape
        
    ' 處理表格（Table）
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        SetFont .Cell(rowIdx, colIdx).Shape.TextFrame
                    End If
                Next colIdx
            Next rowIdx
        End With
        
    ' 處理一般文字方塊、圖案、預留位置 (Placeholder)
    ElseIf shp.HasTextFrame Then
        SetFont shp.TextFrame
    End If
End Sub

' 設定字體的輔助子程式（同時設定中、英與複雜文字屬性）
Private Sub SetFont(tf As TextFrame)
    Const TARGET_FONT As String = "微軟正黑體"
    
    If tf.HasText Then
        With tf.TextRange.Font
            .Name = TARGET_FONT             ' 西文/拉丁字體
            .NameFarEast = TARGET_FONT       ' 中文/東亞字體
            .NameComplexScript = TARGET_FONT ' 複雜語系字體
        End With
    End If
End Sub

一次過運行ABD(只排除標楷體)三個巨集

Sub AllMacros()
    ' 依序呼叫三個巨集
    Call ChangeAnimationsToFadeOut
    Call MuteAllAnimationSounds
    Call ChangeAllFontsIncludingMasters
End Sub

Sub ChangeAnimationsToFadeOut()
    Dim oSlide As Slide
    Dim oEffect As Effect
    Dim oPresentation As Presentation

    Set oPresentation = ActivePresentation

    ' 遍歷每個幻燈片
    For Each oSlide In oPresentation.Slides
        ' 遍歷每個幻燈片上的動畫效果
        For Each oEffect In oSlide.TimeLine.MainSequence
            ' 將動畫效果更改為淡出效果
            oEffect.EffectType = msoAnimEffectFade
            ' 設置淡出效果的速度
            oEffect.Timing.Duration = 0.5
        Next oEffect
    Next oSlide
    ' MsgBox "所有動畫已淡出效果！"
End Sub



Sub MuteAllAnimationSounds()
    Dim sld As Slide
    Dim eff As Effect
    For Each sld In ActivePresentation.Slides
        For Each eff In sld.TimeLine.MainSequence
            ' 只針對有聲音的動畫設為無聲
            If eff.EffectInformation.SoundEffect.Type <> msoSoundNone Then
                eff.EffectInformation.SoundEffect.Type = msoSoundNone
            End If
        Next eff
    Next sld
    ' MsgBox "所有動畫聲音已設為靜音！"
End Sub


Sub ChangeAllFontsIncludingMasters()
    Dim slideItem As Slide
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim shapeItem As Shape
    
    On Error Resume Next
    
    ' 1. 處理所有普通投影片頁面
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            ProcessShape shapeItem, False
        Next shapeItem
    Next slideItem
    
    ' 2. 處理所有投影片母片 (Slide Masters)
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            ProcessShape shapeItem, True
        Next shapeItem
        
        ' 3. 處理母片底下的所有版面配置 (Custom Layouts)
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                ProcessShape shapeItem, True
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' MsgBox "字型已統一為微軟正黑體（排除清單除外，母版與繼承母版的標楷體保留）！", vbInformation, "完成"
End Sub

Private Sub ProcessShape(shp As Shape, isMaster As Boolean)
    Dim rowIdx As Long, colIdx As Long
    Dim subShape As Shape
    
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            ProcessShape subShape, isMaster
        Next subShape
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        SetFont .Cell(rowIdx, colIdx).Shape.TextFrame, isMaster
                    End If
                Next colIdx
            Next rowIdx
        End With
    ElseIf shp.HasTextFrame Then
        SetFont shp.TextFrame, isMaster
    End If
End Sub

Private Sub SetFont(tf As TextFrame, isMaster As Boolean)
    Const TARGET_FONT As String = "微軟正黑體"
    Dim EXCLUDE_FONTS As Variant
    EXCLUDE_FONTS = Array("標楷體", "DFKai-SB", "Times New Roman")
    
    If tf.HasText Then
        With tf.TextRange.Font
            ' 如果字型名稱是空字串 → 表示繼承母版 → 跳過
            If .Name = "" Or .NameFarEast = "" Or .NameComplexScript = "" Then Exit Sub
            
            ' 如果字型在排除清單 → 跳過
            If IsExcluded(.Name, EXCLUDE_FONTS) _
               Or IsExcluded(.NameFarEast, EXCLUDE_FONTS) _
               Or IsExcluded(.NameComplexScript, EXCLUDE_FONTS) Then
               Exit Sub
            End If
            
            ' 其他情況才替換
            .Name = TARGET_FONT
            .NameFarEast = TARGET_FONT
            .NameComplexScript = TARGET_FONT
        End With
    End If
End Sub

Private Function IsExcluded(fontName As String, excludeList As Variant) As Boolean
    Dim f As Variant
    For Each f In excludeList
        If InStr(1, fontName, f, vbTextCompare) > 0 Then
            IsExcluded = True
            Exit Function
        End If
    Next f
    IsExcluded = False
End Function

附：列出簡報內含字型清單，新增到簡報最後一頁：

Sub ListAllFontsToSlide()
    Dim slideItem As Slide
    Dim shapeItem As Shape
    Dim designItem As Design
    Dim layoutItem As CustomLayout
    Dim fontNames As Collection
    Dim f As Variant
    Dim newSlide As Slide
    Dim textBox As Shape
    
    Set fontNames = New Collection
    
    On Error Resume Next
    
    ' 掃描所有投影片
    For Each slideItem In ActivePresentation.Slides
        For Each shapeItem In slideItem.Shapes
            CollectFonts shapeItem, fontNames
        Next shapeItem
    Next slideItem
    
    ' 掃描所有母片與版面配置
    For Each designItem In ActivePresentation.Designs
        For Each shapeItem In designItem.SlideMaster.Shapes
            CollectFonts shapeItem, fontNames
        Next shapeItem
        
        For Each layoutItem In designItem.SlideMaster.CustomLayouts
            For Each shapeItem In layoutItem.Shapes
                CollectFonts shapeItem, fontNames
            Next shapeItem
        Next layoutItem
    Next designItem
    
    On Error GoTo 0
    
    ' 在簡報最後新增一張投影片
    Set newSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutText)
    newSlide.Shapes.Title.TextFrame.TextRange.Text = "簡報字型清單"
    
    ' 建立文字方塊顯示字型清單
    Set textBox = newSlide.Shapes.Placeholders(2)
    textBox.TextFrame.TextRange.Text = "=== 簡報中使用的字型 ===" & vbCrLf
    
    For Each f In fontNames
        textBox.TextFrame.TextRange.Text = textBox.TextFrame.TextRange.Text & f & vbCrLf
    Next f
    
    ' MsgBox "字型清單已插入到簡報最後一張投影片！", vbInformation
End Sub

Private Sub CollectFonts(shp As Shape, fontNames As Collection)
    Dim subShape As Shape
    Dim rowIdx As Long, colIdx As Long
    
    If shp.Type = msoGroup Then
        For Each subShape In shp.GroupItems
            CollectFonts subShape, fontNames
        Next subShape
    ElseIf shp.HasTable Then
        With shp.Table
            For rowIdx = 1 To .Rows.Count
                For colIdx = 1 To .Columns.Count
                    If .Cell(rowIdx, colIdx).Shape.HasTextFrame Then
                        AddFont .Cell(rowIdx, colIdx).Shape.TextFrame.TextRange.Font, fontNames
                    End If
                Next colIdx
            Next rowIdx
        End With
    ElseIf shp.HasTextFrame Then
        AddFont shp.TextFrame.TextRange.Font, fontNames
    End If
End Sub

Private Sub AddFont(fnt As Font, fontNames As Collection)
    Dim fontName As String
    
    On Error Resume Next
    fontName = fnt.Name
    If fontName <> "" Then AddUnique fontName, fontNames
    
    fontName = fnt.NameFarEast
    If fontName <> "" Then AddUnique fontName, fontNames
    
    fontName = fnt.NameComplexScript
    If fontName <> "" Then AddUnique fontName, fontNames
    On Error GoTo 0
End Sub

Private Sub AddUnique(name As String, fontNames As Collection)
    Dim f As Variant
    For Each f In fontNames
        If StrComp(f, name, vbTextCompare) = 0 Then Exit Sub
    Next f
    fontNames.Add name
End Sub

已發佈

分類:

作者:

ivantsoi

標籤: