AutoCAD vba“找不到键”er
在AutoCAD 2009 VBA中，“未找到键”是什么意思。我看起来怎么样对于此错误。
非常感谢。 这通常在例程尝试引用不在相关集合中的命名对象时显示。例如，将对象设置为不存在的图层，或尝试插入名称不属于块表记录的块参照。 这是我的密码“
如果你看到问题，请帮助。
公共子BlkDefAttLayerChg（）
Dim objAttribs作为集合
Dim objAttrib作为AcadAttribute
将objBlock设置为AcadBlock
作为字符串的Dim strAttribs
“”获取块
对于此图形中的每个对象块。阻碍
'strBlockList=strBlockList&vbCr&objBlock。名称
'下一个
设置objBlock=ThisDrawing。阻碍。项目（objBlock.Name）
“”获取属性
设置objAttribs=GetAttributes（objBlock）
“”显示有关每个
对于objAttribs中的每个objAttrib
'strAttribs=objAttrib。标记字符串和vbCrLf
'strAttribs=strAttribs&“标记：”&objAttrib。标记字符串和vbCrLf&_
'提示：“&objAttrib。PromptString&vbCrLf&“值：”&_
“objAttrib。TextString&vbCrLf&“模式：”&_
“objAttrib。模式
'私有m_AttLayerNameOld As String
'Private m_AttLayerNameNew As String
“如果是objAttrib。图层m\u AttLayerNameNew Then
objAttrib。Layer=m_AttLayerNameNew'指定新层名称
'其他
“转到NextItem
'如果结束
strattribsl=objAttrib。层
'MsgBox strAttribs
'MsgBox strattribsl
'NextItem:
下一个
下一个
末端接头
函数GetAttributes（objBlock作为AcadBlock）作为集合
出错时继续下一步
Dim objEnt1作为身份
Dim objAttribute为AcadAttribute
Dim coll作为新系列
“”迭代块
对于objBlock中的每个objEnt1
“”如果是属性
如果objEnt1。ObjectName=“AcDbAttributeDefinition”然后
“”强制转换为属性
设置objAttribute=objEnt1
“”将属性添加到集合
科尔。添加objAttribute，objAttribute。标记字符串“***这会导致错误
'coll。添加对象属性
如果结束
下一个
'返回集合
设置GetAttributes=coll
结束函数 我做了一些改变，看看这是否有帮助。
有几件事表明，发布的代码依赖于未发布的代码。例如，从未设置用m_AttLayerNameNew引用的层名称。在我发布的代码中，我将其设置为一个测试层，我确保该层在图形中可用。
我做的另一个更改是防止例程使用标准AutoCAD blocks Modes\u Space和Paper\u Space运行GetAttributes（）函数。
Public Sub BlkDefAttLayerChg()
Dim objAttribs As Collection
Dim objAttrib As AcadAttribute
Dim objBlock As AcadBlock
Dim strAttribs As String
Dim m_AttLayerNameNew As String
Dim strattribsl As String
'' get the block
For Each objBlock In ThisDrawing.Blocks
'Set objBlock = ThisDrawing.Blocks.Item(objBlock.Name) ''''not needed
If InStr(objBlock.Name, "_Space") = 0 Then 'Don't process Model and Paper space blocks
Set objAttribs = GetAttributes(objBlock)
'' show some information about each
For Each objAttrib In objAttribs
'm_AttLayerNameNew = "TestLayer" ''''used for testing.Layer must be present
objAttrib.Layer = m_AttLayerNameNew ' Assign new layer name
strattribsl = objAttrib.Layer 'is this needed if it's already set in m_AttLayerNameNew
Next
End If
Next
End Sub
Function GetAttributes(objBlock As AcadBlock) As Collection
On Error Resume Next
Dim objEnt1 As AcadEntity
Dim objAttribute As AcadAttribute
Dim coll As New Collection
'' iterate the block
For Each objEnt1 In objBlock
'' if it's an attribute
If objEnt1.ObjectName = "AcDbAttributeDefinition" Then
'' cast to an attribute
Set objAttribute = objEnt1
'' add attribute to the collection
coll.Add objAttribute, objAttribute.TagString '***This causes the error
End If
Next
'return collection
Set GetAttributes = coll
End Function
页:
[1]