我可以得到一份LISP程序吗...请坐。 我认为Bryco的解决方案是VBA而不是口齿不清 VBA会工作得更好！
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
它在vbAssoc上窒息了。
页:
1
[2]