本帖最后由 willj 于 2023-9-12 10:20 编辑
chixun99 发表于 2023-9-11 12:33
dim vAtt as variant
vAtt = AttBlR.GetAttributes
If IsArray(vAtt) Then
Sub SetAttributeValue()
Dim objAcadApp As Object
Dim objAcadDoc As Object
Dim objBlockRef As Object
Dim objBlockRefs As Object
Dim strBlockName As String
Dim strAttributeName As String
Dim strAttributeValue As String
Dim blnBlockRefFound As Boolean
'连接到AutoCAD应用程序
On Error Resume Next
Set objAcadApp = GetObject(, "AutoCAD.Application")
If objAcadApp Is Nothing Then
Set objAcadApp = CreateObject("AutoCAD.Application")
End If
On Error GoTo 0
'检查是否连接到AutoCAD
If objAcadApp Is Nothing Then
MsgBox "无法连接到AutoCAD"
Exit Sub
End If
'获取当前打开的图档
Set objAcadDoc = objAcadApp.ActiveDocument
'检查是否打开了图档
If objAcadDoc Is Nothing Then
MsgBox "未打开图档"
Exit Sub
End If
'获取指定块参照对象的块名称、属性名称和属性值
strBlockName = "测试模块"
strAttributeName = "宽度"
strAttributeValue = "1400"
'遍历所有块参照对象并查找指定块参照对象
For Each objBlockRef In objBlockRefs
If objBlockRef.Name = strBlockName Then
blnBlockRefFound = True
'获取块参照对象的所有属性
Dim vAtt As Variant
vAtt = objBlockRef.GetAttributes
If IsArray(vAtt) Then
'遍历属性集合并查找标签(TagString)等于指定块名称(BlName)的属性
Dim i As Integer
For i = LBound(vAtt) To UBound(vAtt)
If vAtt(i).TagString = strAttributeName Then
'设置属性值(TextString)为指定的值(ValueStr)
vAtt(i).TextString = strAttributeValue
Exit For
End If
Next i
End If
Exit For
End If
Next objBlockRef
'提示块参照对象是否存在
If blnBlockRefFound Then
MsgBox "块参照对象存在"
Else
MsgBox "块参照对象不存在"
End If
End Sub
思路感觉是这样了。就是还有个报错不知道什么情况
本帖最后由 chixun99 于 2023-9-12 14:12 编辑
For Each objBlockRef In objBlockRefs 中的 objBlockRefs 改为选择集，把图纸中的所有图块选到选择集中。
代码中的objBlockRefs这个变量未赋值。
本帖最后由 willj 于 2023-9-12 19:11 编辑
chixun99 发表于 2023-9-12 14:11
For Each objBlockRef In objBlockRefs 中的 objBlockRefs 改为选择集，把图纸中的所有图块选到选择集中。
...找了其他资料用这种方式实现了。好像通过它块参照的名称来指定的话会报错，只有通过指定Set MyObj = acadModelSpace.Item(7)这样去指定这个块参照就可以。你说的这种选择集的方法还未研究出
Sub SetAttributeValue()
Dim acadApp As Object
Dim acadDoc As Object
Dim acadModelSpace As Object
Dim MyObj As Object
Dim val As Double
Dim val2 As Double
Dim val3 As String
'连接到AutoCAD
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err.Number <> 0 Then
Set acadApp = CreateObject("AutoCAD.Application")
End If
On Error GoTo 0
'获取当前文档和模型空间
Set acadDoc = acadApp.ActiveDocument
Set acadModelSpace = acadDoc.ModelSpace
'获取指定块参照对象
Set MyObj = acadModelSpace.Item(7)
If MyObj.EntityName <> "AcDbBlockReference" Then
MsgBox "未找到块参照对象！"
Exit Sub
End If
'修改属性值
val = 1200 '宽度7
val2 = 2100'深度15
val3 = "圆风扇"'平板灯6
Dim varAttributes As Variant
varAttributes = MyObj.GetDynamicBlockProperties
varAttributes(7).value = val
varAttributes(15).value = val2
varAttributes(6).value = val3
'刷新
MyObj.Update
'保存并关闭文档
acadDoc.Save
acadDoc.Close
'释放对象
Set MyObj = Nothing
Set acadModelSpace = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
End Sub
Set MyObj = acadModelSpace.Item(7)这个是整个模型空间（modelspace）中序号7的图元，刚好能蒙到也行吧。其实所有图元就是一个集合（对象），加个循环遍历所有图元，判断是块参照类型、块名（动态块需要用EffectiveName属性来对比）一致就可以了。
cad vba简单，多用就熟悉了。
电梯老表，同行呀
本帖最后由 willj 于 2023-9-13 15:38 编辑
chixun99 发表于 2023-9-13 09:47
Set MyObj = acadModelSpace.Item(7)这个是整个模型空间（modelspace）中序号7的图元，刚好能蒙到也行吧。 ...完美解决了，多谢指点
'循环遍历所有块参照对象
For Each MyObj In acadModelSpace
'判断是否是块参照对象
If MyObj.EntityName = "AcDbBlockReference" Then
'获取块的名称
blkName = MyObj.EffectiveName
'判断是否是要获取动态块属性的块参照对象
If blkName = "测试模块" Then
'获取动态块属性
Dim props As Variant
props = MyObj.GetDynamicBlockProperties
val = Range("B1") '宽度
val2 = Range("B2")'深度
val3 = Range("B3")'平板灯
'循环遍历动态块属性
Dim prop As Variant
For Each prop In props
'获取属性名称和值
On Error Resume Next
Select Case prop.PropertyName
Case "宽度"
prop.value = val
Case "深度"
prop.value = val2
Case "顶开孔"
prop.value = val3
End Select
'刷新
MyObj.Update
Next prop
willj 发表于 2023-9-13 15:36
完美解决了，多谢指点
恭喜又多一个入坑的。
willj 发表于 2023-9-13 15:36
完美解决了，多谢指点
请教下，感觉代码不齐全？
sunny_8848 发表于 2023-9-14 16:24
请教下，感觉代码不齐全？
结合上文就齐了
我也研究一下动态块