代码请求

Private Sub DeleteUnloadedImages()
    On Error GoTo Err_Control
    Dim oDics As AcadDictionaries
    Dim oDic As AcadDictionary
    Dim oD, Imagedef
    Dim i As Integer, sImageName As String
    Dim oImage As AcadRasterImage
    Dim SS As AcadSelectionSet
    Dim Answer As Integer, strPrompt As String
    Dim isThere As Boolean
    Dim obj(0) As AcadEntity
    
    Set oDics = ThisDrawing.Dictionaries
    For Each oD In oDics
        If TypeOf oD Is AcadDictionary Then
            If oD.Name = "ACAD_IMAGE_DICT" Then
                Set oDic = oD
                Set SS = sset(0, "Image")
                For Each Imagedef In oDic
                    sImageName = oDic.GetName(Imagedef)
                     Debug.Print sImageName, vbAssoc(Imagedef, 280)
                    If vbAssoc(Imagedef, 280) = 0 Then
                        strPrompt = "The image: """ & sImageName & """ is unloaded" & vbCrLf & "Choose Yes to delete"
                        Answer = MsgBox(strPrompt, vbYesNo, "Unloaded Image Files")
                        If Answer = vbYes Then
                            Imagedef.Delete
                        End If
                        
                    Else
                        isThere = False
                        If SS.count > 0 Then
                            For Each oImage In SS
                                  If oImage.Name = sImageName Then
                                      isThere = True
                                      Exit For
                                  End If
Nextimage:
                            Next oImage
                            If Not isThere Then
                            Dim bl As Boolean
                            bl = IsNestedImage(sImageName)
                             Debug.Print sImageName, bl
                                If Not IsNestedImage(sImageName) Then
                                    strPrompt = "The image: """ & sImageName _
                                            & """ is unreferenced" & vbCrLf & "Choose Yes to delete"
                                    Answer = MsgBox(strPrompt, vbYesNo, "Unreferenced Image Files")
                                    If Answer = vbYes Then
                                        Imagedef.Delete
                                    End If
                                End If
                            End If
                        End If
                        'SS.Delete
                    End If
                Next Imagedef
                SS.Delete
                Exit For
            End If
        End If
    Next oD
    
Exit_Here:
    Exit Sub
Err_Control:
    Select Case Err.Number
        Case -2145386476  'Key not found
            Set obj(0) = oImage
            SS.RemoveItems obj
            oImage.Delete
            Err.Clear
            GoTo Nextimage
    'Add your Case selections here
        Case Else
        'MsgBox Err.Description
        Debug.Print Err.Number, Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Sub

Public Function sset(FilterType, FilterData As Variant, Optional ssName As String = "SS") As AcadSelectionSet
    
    Dim oSSets As AcadSelectionSets
    Set oSSets = ThisDrawing.SelectionSets
    For Each sset In oSSets
        If sset.Name = ssName Then
            sset.Delete
            Exit For
        End If
    Next
    Dim FType() As Integer
    Dim FData() As Variant
    Dim i As Integer
    If IsArray(FilterType) = False Then
        If IsArray(FilterData) = False Then
            ReDim FType(0)
            ReDim FData(0)
            FType(0) = FilterType
            FData(0) = FilterData
        Else
            Exit Function
        End If
    Else
        If UBound(FilterType)  UBound(FilterData) Then
            Exit Function 'They must be pairs
        End If
        
        ReDim FType(UBound(FilterType))
        ReDim FData(UBound(FilterType))
        For i = 0 To UBound(FilterType)
            FType(i) = FilterType(i)
            FData(i) = FilterData(i)
        Next
    End If
    
    Set sset = ThisDrawing.SelectionSets.Add(ssName)
    sset.Select 5, FilterType:=FType, FilterData:=FData
    'To use this function for single filter
    'Set SS = SSet(0, "insert")
    'For multiple filter
    'Set SS = SSet(array(0,2),array("insert",oBlock.name)) 'must be pairs
End Function