20170709pptVBA递归删除LOGO图片与文字

Public Sub StartRecursionFolder()
    Dim Pre As Presentation
    Dim FolderPath As String
    Dim pp As String
    Dim id As String

    Dim oFileDialog As FileDialog
    Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    'Set Pre = Application.ActivePresentation
    With oFileDialog
        .AllowMultiSelect = False
        '.InitialFileName = Pre.Path & "\"
        If .Show = 0 Then Exit Sub
    End With
    FolderPath = oFileDialog.SelectedItems(1) & "\"
    '递归处理
    RecursionFolder FolderPath
    'MsgBox "批处理完成"
End Sub
Public Sub PresentationHandle(ByVal FilePath As String)
    Application.DisplayAlerts = ppAlertsNone
    Dim Pre As Presentation
    Dim mst As Master
    Dim sld As Slide
    Dim shp As Shape
    Debug.Print FilePath
    Set Pre = Application.Presentations.Open(FilePath)
    '******************************母版的处理**********************
    Dim dsg As Design
    Debug.Print "模板个数"; Pre.Designs.Count

    For Each dsg In Pre.Designs

        Set mst = dsg.SlideMaster
        For Each shp In mst.Shapes
            '删除条件
            Debug.Print shp.Width & "/" & shp.Height; "   "; BetweenSize(shp.Width, 145, 160) And BetweenSize(shp.Height, 30, 55)
            If BetweenSize(shp.Width, 145, 160) And BetweenSize(shp.Height, 30, 55) Then
                shp.Delete
            End If
        Next shp

        If dsg.HasTitleMaster Then
            Set mst = dsg.TitleMaster
            For Each shp In mst.Shapes
                '删除条件
                Debug.Print shp.Width & "/" & shp.Height; "   "; BetweenSize(shp.Width, 145, 160) And BetweenSize(shp.Height, 30, 55)
                If BetweenSize(shp.Width, 145, 160) And BetweenSize(shp.Height, 30, 55) Then
                    shp.Delete
                End If
            Next shp
        End If

    Next dsg



    For Each sld In Pre.Slides
        For Each shp In sld.Shapes
            '删除条件
            If BetweenSize(shp.Width, 145, 160) And BetweenSize(shp.Height, 30, 55) Then
                shp.Delete
            End If
        Next shp
    Next sld


    DeleteShapsInPresentation Pre

    Pre.Save

    Pre.Close


    Set Pre = Nothing
    Set mst = Nothing
    Set sld = Nothing


    Application.DisplayAlerts = ppAlertsAll
End Sub
Private Function BetweenSize(ByVal Size As Double, ByVal MinSize As Double, ByVal MaxSize As Double) As Boolean
    If Size >= MinSize And Size <= MaxSize Then
        BetweenSize = True
    Else
        BetweenSize = False
    End If
End Function
Public Sub RecursionFolder(ByVal FolderPath As String)    '递归文件夹
'声明对象
    Dim Fso As Object
    Dim MainFolder As Object
    Dim OneFolder As Object
    Dim OneFile As Object
    '实例化对象
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set MainFolder = Fso.GetFolder(FolderPath)
    '对文件执行操作
    For Each OneFile In MainFolder.Files
        If OneFile.Name Like "*.ppt*" Then
            '具体要做的事情
            PresentationHandle OneFile.Path
        End If
    Next
    '递归
    For Each OneFolder In MainFolder.SubFolders
        RecursionFolder OneFolder.Path
    Next
    '释放对象
    Set Fso = Nothing
    Set MainFolder = Nothing
End Sub

Private Sub DeleteShapsInPresentation(ByVal Pre As Object)
    Dim sld As Slide
    Dim shp As Shape
    Dim Txt As String
    For Each sld In Pre.Slides
        For Each shp In sld.Shapes
            If shp.HasTextFrame = msoTrue Then
                If shp.TextFrame.HasText Then
                    Txt = shp.TextFrame.TextRange.Text
                    If Txt Like "*更多免费资料下载请进*" Then
                        shp.Delete
                    End If
                End If
            End If
        Next
    Next
    For Each shp In Pre.SlideMaster.Shapes
        If shp.HasTextFrame = msoTrue Then
            If shp.TextFrame.HasText Then
                Txt = shp.TextFrame.TextRange.Text
                If Txt Like "*更多免费资料下载请进*" Then
                    shp.Delete
                End If
            End If
        End If
    Next


End Sub