为什么我的内容删除代码不显示某些已删除项目的更新计数？

Question

我有一个工具栏小部件，可以清除选中复选框的类型的项目。

选择任何或所有复选框后，它应该完成任务并显示已删除项目的计数。

我的问题是，一些项目的计数（例如“未使用的母版幻灯片”）已被删除，但没有显示在向用户显示的计数中。

Private Sub btnExecuteCleanup_Click()

    Dim pptSlide As slide
    Dim pptShape As shape
    Dim hiddenSlidesRemoved As Integer
    Dim speakerNotesCleared As Integer
    Dim draftTextRemoved As Integer
    Dim metadataRemoved As Integer
    Dim commentsRemoved As Integer
    Dim slideNumbersFixed As Integer
    Dim outsideElementsRemoved As Integer
    Dim emptyTextRemoved As Integer
    Dim appendixSlideIndex As Integer
    Dim appendixSlidesRemoved As Integer
    Dim oDesign As Design
    Dim oLayout As CustomLayout
    Dim oShape As shape
    Dim oldYear As String
    Dim newYear As String
    Dim Effect As Effect
    Dim animationsRemoved As Integer
    Dim transitionsRemoved As Integer
    Dim index As Integer
    Dim masterSlidesRemoved As Integer
    Dim layoutsRemoved As Integer
    Dim j As Integer
    Dim i As Integer

    ' Initialize counters
    hiddenSlidesRemoved = 0
    speakerNotesCleared = 0
    draftTextRemoved = 0
    metadataRemoved = 0
    commentsRemoved = 0
    slideNumbersFixed = 0
    outsideElementsRemoved = 0
    emptyTextRemoved = 0
    appendixSlideIndex = 0
    appendixSlidesRemoved = 0
    animationsRemoved = 0
    transitionsRemoved = 0
    masterSlidesRemoved = 0
    layoutsRemoved = 0
    
    ' Replace Year in Footer
    If chkReplaceYearInFooter.Value = True Then
        ReplaceYearInFooter
    End If
    
    ' Remove Animations and Transitions
    If chkRemoveAnimationsAndTransitions.Value = True Then
        RemoveAnimationsAndTransitions animationsRemoved, transitionsRemoved
    End If
    
    ' Remove unused master slides and layouts
    If btnRemoveUnusedMasters.Value = True Then
        RemoveUnusedMasterSlidesAndLayouts
    End If


    ' Remove Hidden Slides
       If chkRemoveHiddenSlides.Value = True Then
        For i = ActivePresentation.Slides.Count To 1 Step -1
            Set pptSlide = ActivePresentation.Slides(i)
            If pptSlide.SlideShowTransition.Hidden = msoTrue Then
                pptSlide.Delete
                hiddenSlidesRemoved = hiddenSlidesRemoved + 1
            End If
        Next i
    End If
    
    ' Remove Speaker Notes
    If chkRemoveSpeakerNotes.Value = True Then
        For Each pptSlide In ActivePresentation.Slides
            If pptSlide.NotesPage.Shapes.Placeholders(2).TextFrame.textRange.Text <> "" Then
                pptSlide.NotesPage.Shapes.Placeholders(2).TextFrame.textRange.Text = ""
                speakerNotesCleared = speakerNotesCleared + 1
            End If
        Next pptSlide
    End If
    
    ' Remove Draft Text
    If chkRemoveEmptyTextOrDraft.Value = True Then
    
    For Each pptSlide In ActivePresentation.Slides
        ' Loop backward through shapes as deleting will affect the collection index
        For i = pptSlide.Shapes.Count To 1 Step -1
            Set pptShape = pptSlide.Shapes.Item(i)
            
            ' Check if the shape has a text frame
            If pptShape.HasTextFrame Then
                ' Check if the text frame is empty
                If Not pptShape.TextFrame.HasText Then
                    pptShape.Delete
                    emptyTextRemoved = emptyTextRemoved + 1
                Else
                    ' Check for draft text and remove it
                    If InStr(pptShape.TextFrame.textRange.Text, "Draft") > 0 Then
                        pptShape.TextFrame.textRange.Text = Replace(pptShape.TextFrame.textRange.Text, "Draft", "")
                        draftTextRemoved = draftTextRemoved + 1
                    End If
                End If
            End If
        Next i
    Next pptSlide
    End If

    ' Remove Metadata
    If chkRemoveMetadata.Value = True Then
    Dim prop As DocumentProperty
    
    ' Loop through built-in document properties and clear them
    For i = ActivePresentation.BuiltInDocumentProperties.Count To 1 Step -1
        On Error Resume Next  ' Skip properties that can't be deleted or modified
        Set prop = ActivePresentation.BuiltInDocumentProperties(i)
        prop.Value = ""
        On Error GoTo 0  ' Reset error handling to default behavior
    Next i
    metadataRemoved = 1 ' Update the counter
    End If
    
    ' Remove Comments
    If chkRemoveComments.Value = True Then
    Dim pptComment As Comment
    For Each pptSlide In ActivePresentation.Slides
        ' Loop backward through comments as deleting will affect the collection index
        For i = pptSlide.Comments.Count To 1 Step -1
            Set pptComment = pptSlide.Comments.Item(i)
            pptComment.Delete
            commentsRemoved = commentsRemoved + 1
        Next i
    Next pptSlide
    End If
    
    ' Fix Slide Numbers in Master Slides
    If chkFixSlideNumbers.Value = True Then
    Dim shp As shape
    Dim foundFirst As Boolean
    Dim slideMaster As Master
    
    Set slideMaster = ActivePresentation.slideMaster
    
    foundFirst = False
    For Each shp In slideMaster.Shapes
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                If InStr(1, shp.TextFrame.textRange.Text, "<#>") > 0 Then
                    If foundFirst Then
                        shp.Delete ' Delete duplicates
                    Else
                        foundFirst = True ' Keep the first one
                    End If
                    slideNumbersFixed = slideNumbersFixed + 1
                End If
            End If
        End If
    Next shp
    End If

    ' Remove Elements Outside Slides
    If chkRemoveOutsideElements.Value = True Then
    Dim slideWidth As Single, slideHeight As Single
    slideWidth = ActivePresentation.PageSetup.slideWidth
    slideHeight = ActivePresentation.PageSetup.slideHeight
    
    For Each pptSlide In ActivePresentation.Slides
        ' Loop backward through shapes as deleting will affect the collection index
        For i = pptSlide.Shapes.Count To 1 Step -1
            Set pptShape = pptSlide.Shapes.Item(i)
            
            ' Check if the shape is completely outside the slide
            If pptShape.Left + pptShape.width < 0 Or pptShape.Left > slideWidth Or _
               pptShape.Top + pptShape.height < 0 Or pptShape.Top > slideHeight Then
                   
                ' Check if the shape is not part of any animation sequence
                Dim isAnimated As Boolean
                isAnimated = False
                For Each Effect In pptSlide.TimeLine.MainSequence
                    If Effect.shape.Id = pptShape.Id Then
                        isAnimated = True
                        Exit For
                    End If
                Next Effect
                
                ' Delete the shape if it's not animated
                If Not isAnimated Then
                    pptShape.Delete
                    outsideElementsRemoved = outsideElementsRemoved + 1
                End If
            End If
        Next i
    Next pptSlide
    End If
    

    ' Remove "Appendix" and slides after it
    If chkRemoveAppendix.Value = True Then
    ' Find the "Appendix" slide
    For Each pptSlide In ActivePresentation.Slides
        If pptSlide.Shapes.Placeholders.Count >= 1 Then  ' Check if at least one placeholder exists
            If pptSlide.Shapes.Placeholders(1).TextFrame.textRange.Text = "Appendix" Then
                appendixSlideIndex = pptSlide.slideIndex
                Exit For
            End If
        End If
    Next pptSlide

    ' Remove "Appendix" slide and all slides after it
    If appendixSlideIndex > 0 Then
        For i = ActivePresentation.Slides.Count To appendixSlideIndex Step -1
            ActivePresentation.Slides(i).Delete
            appendixSlidesRemoved = appendixSlidesRemoved + 1
        Next i
    End If
    End If  ' This closes the chkRemoveAppendix condition

    ' Close the UserForm
    Unload Me

    ' Show the summary message with custom title "Clean-Up Summary"
    MsgBox "Cleanup Completed." & vbNewLine & _
           "Hidden slides removed: " & CStr(hiddenSlidesRemoved) & vbNewLine & _
           "Speaker notes cleared: " & CStr(speakerNotesCleared) & vbNewLine & _
           "Empty text box placeholders removed: " & CStr(draftTextRemoved) & vbNewLine & _
           "Metadata cleared: " & CStr(metadataRemoved) & vbNewLine & _
           "Comments removed: " & CStr(commentsRemoved) & vbNewLine & _
           "Slide numbers fixed: " & CStr(slideNumbersFixed) & vbNewLine & _
           "Objects outside slides removed: " & CStr(outsideElementsRemoved) & vbNewLine & _
           "Appendix slides removed: " & CStr(appendixSlidesRemoved) & vbNewLine & _
           "Animations removed: " & CStr(animationsRemoved) & vbNewLine & _
           "Transitions removed: " & CStr(transitionsRemoved) & vbNewLine & _
           "Unused Master slides removed: " & CStr(masterSlidesRemoved) & vbNewLine & _
           "Unused Layouts removed: " & CStr(layoutsRemoved)
End Sub

Sub ReplaceYearInFooter()
    Dim oDesign As Design
    Dim oLayout As CustomLayout
    Dim oShape As shape
    Dim oldYear As String
    Dim newYear As String
    
    ' Get the current year
    newYear = CStr(Year(Now))
    
    ' Loop through each design
    For Each oDesign In ActivePresentation.Designs
        ' Loop through each layout in the slide master
        For Each oLayout In oDesign.slideMaster.CustomLayouts
            ' Loop through each shape in the layout
            For Each oShape In oLayout.Shapes
                ' Check if the shape has a text frame and text
                If oShape.HasTextFrame And oShape.TextFrame.HasText Then
                    ' Replace the year in the footer
                    oldYear = oShape.TextFrame.textRange.Text
                    oShape.TextFrame.textRange.Text = Replace(oldYear, "2022", newYear)
                End If
            Next oShape
        Next oLayout
    Next oDesign
End Sub
 
Private Sub btnRemoveAnimationsTransitions_Click()
    
    ' If you want to show a message box summarizing what was removed
    MsgBox "Animations removed: " & animationsRemoved & vbNewLine & _
           "Transitions removed: " & transitionsRemoved, vbInformation, "Removal Summary"
End Sub

    ' Button to Standardize Titles
Private Sub btnStandardizeTitles_Click()
    StandardizeTitles
End Sub

' Standardize Titles Subroutine
Sub StandardizeTitles()
    Dim srcSld As slide
    Dim trgSld As slide
    Dim srcShp As shape
    Dim trgShp As shape
    
    ' Check if a presentation is open
    If Not ActivePresentation Is Nothing Then
        ' Check if a slide is selected
        If Not ActiveWindow.View.slide Is Nothing Then
            Set srcSld = ActiveWindow.View.slide
        Else
            Exit Sub
        End If
    Else
        Exit Sub
    End If
    
    ' Find the title shape on the source slide
    For Each srcShp In srcSld.Shapes
        If srcShp.Type = msoPlaceholder Then
            If srcShp.PlaceholderFormat.Type = ppPlaceholderTitle Then
                Exit For
            End If
        End If
    Next srcShp
    
    ' Check if title shape exists on source slide
    If srcShp Is Nothing Then Exit Sub
    
    ' Loop through all slides in the presentation
    For Each trgSld In ActivePresentation.Slides
        ' Find the title shape on the target slide
        For Each trgShp In trgSld.Shapes
            If trgShp.Type = msoPlaceholder Then
                If trgShp.PlaceholderFormat.Type = ppPlaceholderTitle Then
                    ' Standardize position
                    trgShp.Top = srcShp.Top
                    trgShp.Left = srcShp.Left
                    trgShp.width = srcShp.width
                    trgShp.height = srcShp.height
                    
                    ' Standardize font color and size only
                    trgShp.TextFrame.textRange.Font.Name = srcShp.TextFrame.textRange.Font.Name
                    trgShp.TextFrame.textRange.Font.Size = srcShp.TextFrame.textRange.Font.Size
                    trgShp.TextFrame.textRange.Font.Color.RGB = srcShp.TextFrame.textRange.Font.Color.RGB
                    Exit For
                End If
            End If
        Next trgShp
    Next trgSld
End Sub

Sub RemoveAnimationsAndTransitions(ByRef animationsRemoved As Integer, ByRef transitionsRemoved As Integer)
    Dim pptSlide As slide
    Dim pptEffect As Effect
    
    ' Initialize counters
    animationsRemoved = 0
    transitionsRemoved = 0
    
    ' Loop through each slide in the presentation
    For Each pptSlide In ActivePresentation.Slides
        ' Remove animations
        For Each pptEffect In pptSlide.TimeLine.MainSequence
            pptEffect.Delete
            animationsRemoved = animationsRemoved + 1
        Next pptEffect
        
        ' Remove transitions
        With pptSlide.SlideShowTransition
            .EntryEffect = ppEffectNone
            transitionsRemoved = transitionsRemoved + 1
        End With
    Next pptSlide
End Sub

Sub RemoveUnusedMasterSlidesAndLayouts()
   ' Remove unused master slides and layouts
Dim oPres As presentation
Dim isDesignUsed As Boolean
Dim isLayoutUsed As Boolean
Set oPres = ActivePresentation

For i = oPres.Designs.Count To 1 Step -1
    Set oDesign = oPres.Designs(i)
    isDesignUsed = False

    For Each oSlide In oPres.Slides
        If oSlide.Design Is oDesign Then
            isDesignUsed = True
            Exit For
        End If
    Next oSlide

    If Not isDesignUsed Then
        oDesign.Delete
        masterSlidesRemoved = masterSlidesRemoved + 1
    Else
        For j = oDesign.slideMaster.CustomLayouts.Count To 1 Step -1
            Set oLayout = oDesign.slideMaster.CustomLayouts(j)
            isLayoutUsed = False

            For Each oSlide In oPres.Slides
                If oSlide.CustomLayout Is oLayout Then
                    isLayoutUsed = True
                    Exit For
                End If
            Next oSlide

            If Not isLayoutUsed Then
                oLayout.Delete
                layoutsRemoved = layoutsRemoved + 1
            End If
        Next j
    End If
Next i


End Sub
    
Private Sub chkRemoveDraftText_Click()

End Sub

Private Sub CheckBox2_Click()

End Sub

Private Sub chkRemoveAnimationsAndTransitions_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
    Dim msgResponse As VbMsgBoxResult

    msgResponse = MsgBox("To prevent data loss, kindly use each checklist options with utmost caution.", vbExclamation + vbOKCancel, "Warning")

    If msgResponse = vbCancel Then
        Unload Me
    End If
End Sub

任何人都可以帮我找出哪里出错了吗？

Answer 1

变量范围对于编码至关重要。例如：

• masterSlidesRemoved

  是在

  Sub btnExecuteCleanup_Click()

  中定义的，所以它的范围被限制在

  btnExecuteCleanup_Click

  内。您无法在其他子目录中读取或更新它。

Dim masterSlidesRemoved As Integer

• 但是，

  masterSlidesRemoved

  已在

  Sub RemoveUnusedMasterSlidesAndLayouts()

  中更新。它是一个新变量，与上面定义的变量没有任何关系。

当构建输出消息时，

• masterSlidesRemoved

  中的

  btnExecuteCleanup_Click

  始终为零，如下所示。

"Unused Master slides removed: " & CStr(masterSlidesRemoved) & vbNewLine & _

---

选项 1：将

masterSlidesRemoved

定义为模块级变量，将

Dim

从

masterSlidesRemoved

移动到模块顶部。

Dim masterSlidesRemoved As Integer

Private Sub btnExecuteCleanup_Click()
    ' Dim masterSlidesRemoved As Integer **remove**
    ' your code
End Sub
Sub RemoveUnusedMasterSlidesAndLayouts()
    ' your code - no change
End Sub

---

选项 2：将

RemoveUnusedMasterSlidesAndLayouts

从

Sub

更改为

Function

Private Sub btnExecuteCleanup_Click()
    Dim masterSlidesRemoved As Integer
    ' your code - no change
    ' Remove unused master slides and layouts
    If btnRemoveUnusedMasters.Value = True Then
        masterSlidesRemoved = RemoveUnusedMasterSlidesAndLayouts  '**modify**
    End If
    ' ' your code
End Sub

Function RemoveUnusedMasterSlidesAndLayouts() as Integer  '**modify**
    Dim masterSlidesRemoved As Integer '**add**
    ' your code - no change
    RemoveUnusedMasterSlidesAndLayouts = masterSlidesRemoved '**add**
End Sub