2145386484-未知句柄

兰州人 · 发表于 2008-7-24 12:25:00

本帖最后由作者于 2008-7-24 12:33:44 编辑

在找尺寸线的起点和终点坐标时，经常会出现如下情况。
2145386484--未知句柄
在http://forums.augi.com/archive/index.php/t-5547.html有这段描述
'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.
这是老版本生成的块，不能随父节点在块开始点1之上找到块关联句柄。只有不断循环才能找到它，块的结束部分仍然在块开始的1上。
原程序如下：

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 Boolean
Set 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 Sub
Public 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 Integer
Dim 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 = s1
End 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 String
strHandle = 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 = arySeqEnd
Exit_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

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 Boolean

Set 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 Sub

Public 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 Integer

Dim 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 = s1

End 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 String

strHandle = 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 = arySeqEnd

Exit_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

[url=http://forums.augi.com/archive/index.php/t-5547.html][/url]

账号		自动登录	找回密码
密码			注册