问题描述:
在ppt vba中如果要循环批量删除Shape对象,会遇到很多困难。比如当执行如下For Each … In 的vba代码删除ppt中第一页的所有图片后,会发现并没有将图片全部删除:
Sub DeleteBrandLogo()
Dim pre As PowerPoint.Presentation, shp As PowerPoint.Shape, Sli As PowerPoint.Slide
For Each sld In pre.Slides
For Each shp In sld.Shapes
If shp.Name Like "LOGO_*" Then
shp.DeleteEnd If
Next
Next
End Sub
而当修改为执行如下的For i = 1 To .Shapes.Count 的vba代码删除ppt中第一页中的所有图片时:
Sub DeleteBrandLogo()
Dim pre As PowerPoint.Presentation, shp As PowerPoint.Shape, Sli As PowerPoint.Slide,i&
For Each sld In pre.Slides
For i = 1 to sld.Shapes.Count
If sld.Shapes(i).Name Like "LOGO_*" Then
sld.Shapes(i).Delete
End If
Next
Next
End Sub
会弹出数字已经超出边界的提示错误如下图所示:
解决办法:
- 原因分析:以上两种批量删除对象的方法在excel vba和word vba中都是最常用的,而且也是最安全的删除方法,但是到了ppt vba中却都不行了,经过仔细的分析,原来ppt vba中每删除一个对象,会自动调整所有对象的索引号,导致有些索引号空缺,从而出现删不尽或者索引号超出边界的现象发生!
- 解决办法:需要每次将要删除的对象的名称存入数组,然后用ShapeRange对象删除:
Sub DeleteBrandLogo(pre As PowerPoint.Presentation)
Dim shp As PowerPoint.Shape, Sli As PowerPoint.Slide, arr(), k&, lb&
For Each sld In pre.Slides
k = 0
Erase arr
For Each shp In sld.Shapes
If shp.Name Like "LOGO_*" Then
ReDim Preserve arr(k)
arr(k) = shp.Name
k = k + 1
End If
Next
On Error Resume Next
lb = UBound(arr)
If Err.Number <> 9 Then
sld.Shapes.Range(arr).Delete
Debug.Print "Delete P" & sld.SlideIndex & ":" & Join(arr, ",")
End If
On Error GoTo 0
Next
Debug.Print "delete ok!"
End Sub
执行完代码后,发现已经全部删除好了!
问题描述:
在ppt vba中如果要循环批量删除Shape对象,会遇到很多困难。比如当执行如下For Each … In 的vba代码删除ppt中第一页的所有图片后,会发现并没有将图片全部删除:
Sub DeleteBrandLogo()
Dim pre As PowerPoint.Presentation, shp As PowerPoint.Shape, Sli As PowerPoint.Slide
For Each sld In pre.Slides
For Each shp In sld.Shapes
If shp.Name Like "LOGO_*" Then
shp.DeleteEnd If
Next
Next
End Sub
而当修改为执行如下的For i = 1 To .Shapes.Count 的vba代码删除ppt中第一页中的所有图片时:
Sub DeleteBrandLogo()
Dim pre As PowerPoint.Presentation, shp As PowerPoint.Shape, Sli As PowerPoint.Slide,i&
For Each sld In pre.Slides
For i = 1 to sld.Shapes.Count
If sld.Shapes(i).Name Like "LOGO_*" Then
sld.Shapes(i).Delete
End If
Next
Next
End Sub
会弹出数字已经超出边界的提示错误如下图所示:
解决办法:
- 原因分析:以上两种批量删除对象的方法在excel vba和word vba中都是最常用的,而且也是最安全的删除方法,但是到了ppt vba中却都不行了,经过仔细的分析,原来ppt vba中每删除一个对象,会自动调整所有对象的索引号,导致有些索引号空缺,从而出现删不尽或者索引号超出边界的现象发生!
- 解决办法:需要每次将要删除的对象的名称存入数组,然后用ShapeRange对象删除:
Sub DeleteBrandLogo(pre As PowerPoint.Presentation)
Dim shp As PowerPoint.Shape, Sli As PowerPoint.Slide, arr(), k&, lb&
For Each sld In pre.Slides
k = 0
Erase arr
For Each shp In sld.Shapes
If shp.Name Like "LOGO_*" Then
ReDim Preserve arr(k)
arr(k) = shp.Name
k = k + 1
End If
Next
On Error Resume Next
lb = UBound(arr)
If Err.Number <> 9 Then
sld.Shapes.Range(arr).Delete
Debug.Print "Delete P" & sld.SlideIndex & ":" & Join(arr, ",")
End If
On Error GoTo 0
Next
Debug.Print "delete ok!"
End Sub
执行完代码后,发现已经全部删除好了!