2145386484-未知句柄

Public Sub BlockEntsByLayer()
Dim oBlk As AcadBlock
Dim oBlk1 As AcadBlock
Dim oBlkRef As AcadBlockReference
Dim oBlkRef1 As AcadBlockReference
Dim oEnt As AcadEntity
Dim oEnt1 As AcadEntity
Dim ss As AcadSelectionSet
Dim SeqEnd As AcadEntity
Dim blkent As AcadObject
Dim EntArray As Variant
Dim HasSEQE As BooleanSet ss = GetSS_BlockFilter
For Each oBlkRef In ss
Set oBlk = ThisDrawing.Blocks(oBlkRef.Name)
If Not oBlk.IsXRef Then
'process BlockBegin and BlockEnd
HasSEQE = GetSeqEnd(oBlk, EntArray)
If HasSEQE = True Then
Set oEnt = EntArray(0)
oEnt.Layer = "0"
Set oEnt = EntArray(1)
oEnt.Layer = "0"
End If
For Each oEnt In oBlk
Set blkent = oBlk
'process sub ents
If TypeOf oEnt Is AcadBlockReference Then
Set oBlkRef1 = oEnt
Set oBlk1 = ThisDrawing.Blocks(oBlkRef1.Name)
For Each oEnt1 In oBlk1
With oEnt1
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
Next oEnt1
Else
With oEnt
If Not ThisDrawing.Layers(.Layer).Lock Then
.Layer = "0"
.Color = acByLayer
End If
End With
End If
Next oEnt
End If
Next oBlkRef
ThisDrawing.Regen acAllViewports
End SubPublic Sub AddSelectionSet(ss As AcadSelectionSet, SetName As String)
' This routine does the error trapping neccessary for when you want to create a
' selectin set. It takes the set and the proposed name and either adds it to the selectionsets
' collection or sets it.
On Error Resume Next
Set ss = ThisDrawing.SelectionSets.Add(SetName)
If Err.Number  0 Then
Set ss = ThisDrawing.SelectionSets.Item(SetName)
End If
End Sub
Public Function GetSS_BlockFilter() As AcadSelectionSet
'creates an ss of Blocks only
Dim s1 As AcadSelectionSet
Dim objEnts(0) As AcadEntity
Dim oEnt As AcadEntity
Dim lispCode As VLAX
Dim i As IntegerDim intFtyp(0) As Integer ' setup for the filter
Dim varFval(0) As Variant
Dim varFilter1, varFilter2 As Variant
intFtyp(0) = 0: varFval(0) = "INSERT" ' get only blocks
varFilter1 = intFtyp: varFilter2 = varFval'check for PickFirst selection set
Set s1 = ThisDrawing.PickfirstSelectionSet
If s1.Count > 0 Then
Set lispCode = Toolbox.CreateVLAXClass
'create a working ss in lisp environment
lispCode.EvalLispExpression "(setq ss (ssadd))"
For Each oEnt In s1
'transfer only blocks to the lisp ss
'here's where the filtering is done
If TypeOf oEnt Is AcadBlockReference Then
lispCode.EvalLispExpression "(ssadd " & _
"(handent " & Chr(34) & _
oEnt.Handle & Chr(34) & ")" & _
"ss" & _
")"
End If
Next oEnt
'clear orig pfss of ents, may contain other than text
s1.Clear
'set the pfss to the now filtered lisp ss
lispCode.EvalLispExpression "(sssetfirst nil ss)"
lispCode.EvalLispExpression "(setq ss nil)"
'transfer to a named ss and then deselect the pfss
AddSelectionSet s1, "ssBlockFilter"
Set s1 = ThisDrawing.PickfirstSelectionSet
lispCode.EvalLispExpression "(sssetfirst nil)"
Set lispCode = Nothing
Else
AddSelectionSet s1, "ssBlockFilter" ' create or get the set
s1.Clear ' clear the set
s1.SelectOnScreen varFilter1, varFilter2 ' do it
End If
Set GetSS_BlockFilter = s1End Function
Public Function GetSeqEnd(objBlock As AcadBlock, EntArray As Variant) As Boolean
On Error GoTo Err_Control
'Returns True if BlockBegin or BlockEnd entities are found
'and returns them in the supplied array, a 2d array of AcadEnity.
Dim objSeqEnd As AcadEntity
Dim arySeqEnd(1) As AcadEntity
Dim strIHex As String
Dim strHandle As String
Dim strLeftHex As String
Dim strOwner As StringstrHandle = objBlock.Handle
strLeftHex = Left(strHandle, Len(strHandle) - 2)
strIHex = "&H" & Right(objBlock.Handle, 2)
Do
ContLoop:
strIHex = strIHex + 1
Set objSeqEnd = _
ThisDrawing.HandleToObject(strLeftHex & Hex(strIHex))
strOwner = objSeqEnd.OwnerID
If objSeqEnd.ObjectName = "AcDbBlockBegin" Then
Set arySeqEnd(0) = objSeqEnd
GetSeqEnd = True
End If
If objSeqEnd.ObjectName = "AcDbBlockEnd" Then
Set arySeqEnd(1) = objSeqEnd
GetSeqEnd = True
Exit Do
End If
'Keep the loop from exceeding the reference members
Loop Until strOwner  objBlock.ObjectID
If GetSeqEnd = True Then EntArray = arySeqEndExit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case -2145386484
'Not a valid handle.
'This could be an older block that doesn't
'follow the pattern of BlockBegin's handle
'starting at 1 above the block handle.
'Continue the loop until you find it.
'BlockEnd should still be 1 above BlockBegin.
Resume ContLoop
Case Else
MsgBox Err.Number & ", " & Err.Description, , "GetSeqEnd"
Resume Exit_Here
End Select
End Function