20170709pptVBA递归删除LOGO图片与文字
Posted Excel VBA 小天地
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了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
以上是关于20170709pptVBA递归删除LOGO图片与文字的主要内容,如果未能解决你的问题,请参考以下文章