随笔 - 66 文章 - 0 评论 - 2 阅读 - 26万

VBA错误：批量删除PPT的Shape对象时发现漏删了

问题描述：

　　在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