已解决，在excel中通过VBA修改CAD中的动态块的自定义属性值

willj

如图想在excel中使用VBA修改红色箭头的值，更新保存到CAD中去。

willj

chixun99 发表于 2023-9-13 09:47
Set MyObj = acadModelSpace.Item(7)这个是整个模型空间（modelspace）中序号7的图元，刚好能蒙到也行吧。 ...

完美解决了，多谢指点

2.     '循环遍历所有块参照对象
   
3.     For Each MyObj In acadModelSpace
   
4.         '判断是否是块参照对象
   
5.         If MyObj.EntityName = "AcDbBlockReference" Then
   
6.             '获取块的名称
   
7.             blkName = MyObj.EffectiveName
   
8.             '判断是否是要获取动态块属性的块参照对象
   
9.             If blkName = "测试模块" Then
   
10.                 '获取动态块属性
    
11.                 Dim props As Variant
    
12.                 props = MyObj.GetDynamicBlockProperties
    
13.                
    
14.                 val = Range("B1")   '宽度
    
15.                 val2 = Range("B2")  '深度
    
16.                 val3 = Range("B3")  '平板灯
    
17.                 '循环遍历动态块属性
    
18.                 Dim prop As Variant
    
19.                 For Each prop In props
    
20.                     '获取属性名称和值
    
21.                     On Error Resume Next
    
22.                     Select Case prop.PropertyName
    
23.                         Case "宽度"
    
24.                             prop.value = val
    
25.                         Case "深度"
    
26.                             prop.value = val2
    
27.                         Case "顶开孔"
    
28.                             prop.value = val3
    
29.                     End Select
    
30.                     
    
31.                 '刷新
    
32.                 MyObj.Update
    
33.                 Next prop

    '循环遍历所有块参照对象<br />     For Each MyObj In acadModelSpace<br />         '判断是否是块参照对象<br />         If MyObj.EntityName = "AcDbBlockReference" Then<br />             '获取块的名称<br />             blkName = MyObj.EffectiveName<br />             '判断是否是要获取动态块属性的块参照对象<br />             If blkName = "测试模块" Then<br />                 '获取动态块属性<br />                 Dim props As Variant<br />                 props = MyObj.GetDynamicBlockProperties<br />                 <br />                 val = Range("B1")   '宽度<br />                 val2 = Range("B2")  '深度<br />                 val3 = Range("B3")  '平板灯<br />                 '循环遍历动态块属性<br />                 Dim prop As Variant<br />                 For Each prop In props<br />                     '获取属性名称和值<br />                     On Error Resume Next<br />                     Select Case prop.PropertyName<br />                         Case "宽度"<br />                             prop.value = val<br />                         Case "深度"<br />                             prop.value = val2<br />                         Case "顶开孔"<br />                             prop.value = val3<br />                     End Select<br />                     <br />                 '刷新<br />                 MyObj.Update<br />                 Next prop

哆啦lulu

willj 发表于 2023-9-13 15:36
完美解决了，多谢指点

为什么我运行prop.value = val的时候会报错，从官网文档上看prop.value 是不能修改的

willj

chixun99 发表于 2023-9-11 12:33
dim vAtt as variant
vAtt = AttBlR.GetAttributes
            If IsArray(vAtt) Then

1. Sub SetAttributeValue()
   
2.     Dim objAcadApp As Object
   
3.     Dim objAcadDoc As Object
   
4.     Dim objBlockRef As Object
   
5.     Dim objBlockRefs As Object
   
6.     Dim strBlockName As String
   
7.     Dim strAttributeName As String
   
8.     Dim strAttributeValue As String
   
9.     Dim blnBlockRefFound As Boolean
   
10. 
    
11.     '连接到AutoCAD应用程序
    
12.     On Error Resume Next
    
13.     Set objAcadApp = GetObject(, "AutoCAD.Application")
    
14.     If objAcadApp Is Nothing Then
    
15.         Set objAcadApp = CreateObject("AutoCAD.Application")
    
16.     End If
    
17.     On Error GoTo 0
    
18. 
    
19.     '检查是否连接到AutoCAD
    
20.     If objAcadApp Is Nothing Then
    
21.         MsgBox "无法连接到AutoCAD"
    
22.         Exit Sub
    
23.     End If
    
24. 
    
25.     '获取当前打开的图档
    
26.     Set objAcadDoc = objAcadApp.ActiveDocument
    
27. 
    
28.     '检查是否打开了图档
    
29.     If objAcadDoc Is Nothing Then
    
30.         MsgBox "未打开图档"
    
31.         Exit Sub
    
32.     End If
    
33. 
    
34.     '获取指定块参照对象的块名称、属性名称和属性值
    
35.     strBlockName = "测试模块"
    
36.     strAttributeName = "宽度"
    
37.     strAttributeValue = "1400"
    
38. 
    
39. 
    
40.     '遍历所有块参照对象并查找指定块参照对象
    
41.     For Each objBlockRef In objBlockRefs
    
42.         If objBlockRef.Name = strBlockName Then
    
43.             blnBlockRefFound = True
    
44.             '获取块参照对象的所有属性
    
45.             Dim vAtt As Variant
    
46.             vAtt = objBlockRef.GetAttributes
    
47.             If IsArray(vAtt) Then
    
48.                 '遍历属性集合并查找标签(TagString)等于指定块名称(BlName)的属性
    
49.                 Dim i As Integer
    
50.                 For i = LBound(vAtt) To UBound(vAtt)
    
51.                     If vAtt(i).TagString = strAttributeName Then
    
52.                         '设置属性值(TextString)为指定的值(ValueStr)
    
53.                         vAtt(i).TextString = strAttributeValue
    
54.                         Exit For
    
55.                     End If
    
56.                 Next i
    
57.             End If
    
58.             Exit For
    
59.         End If
    
60.     Next objBlockRef
    
61. 
    
62.     '提示块参照对象是否存在
    
63.     If blnBlockRefFound Then
    
64.         MsgBox "块参照对象存在"
    
65.     Else
    
66.         MsgBox "块参照对象不存在"
    
67.     End If
    
68. End Sub
    

Sub SetAttributeValue()<br />     Dim objAcadApp As Object<br />     Dim objAcadDoc As Object<br />     Dim objBlockRef As Object<br />     Dim objBlockRefs As Object<br />     Dim strBlockName As String<br />     Dim strAttributeName As String<br />     Dim strAttributeValue As String<br />     Dim blnBlockRefFound As Boolean<br /> <br />     '连接到AutoCAD应用程序<br />     On Error Resume Next<br />     Set objAcadApp = GetObject(, "AutoCAD.Application")<br />     If objAcadApp Is Nothing Then<br />         Set objAcadApp = CreateObject("AutoCAD.Application")<br />     End If<br />     On Error GoTo 0<br /> <br />     '检查是否连接到AutoCAD<br />     If objAcadApp Is Nothing Then<br />         MsgBox "无法连接到AutoCAD"<br />         Exit Sub<br />     End If<br /> <br />     '获取当前打开的图档<br />     Set objAcadDoc = objAcadApp.ActiveDocument<br /> <br />     '检查是否打开了图档<br />     If objAcadDoc Is Nothing Then<br />         MsgBox "未打开图档"<br />         Exit Sub<br />     End If<br /> <br />     '获取指定块参照对象的块名称、属性名称和属性值<br />     strBlockName = "测试模块"<br />     strAttributeName = "宽度"<br />     strAttributeValue = "1400"<br /> <br /> <br />     '遍历所有块参照对象并查找指定块参照对象<br />     For Each objBlockRef In objBlockRefs<br />         If objBlockRef.Name = strBlockName Then<br />             blnBlockRefFound = True<br />             '获取块参照对象的所有属性<br />             Dim vAtt As Variant<br />             vAtt = objBlockRef.GetAttributes<br />             If IsArray(vAtt) Then<br />                 '遍历属性集合并查找标签(TagString)等于指定块名称(BlName)的属性<br />                 Dim i As Integer<br />                 For i = LBound(vAtt) To UBound(vAtt)<br />                     If vAtt(i).TagString = strAttributeName Then<br />                         '设置属性值(TextString)为指定的值(ValueStr)<br />                         vAtt(i).TextString = strAttributeValue<br />                         Exit For<br />                     End If<br />                 Next i<br />             End If<br />             Exit For<br />         End If<br />     Next objBlockRef<br /> <br />     '提示块参照对象是否存在<br />     If blnBlockRefFound Then<br />         MsgBox "块参照对象存在"<br />     Else<br />         MsgBox "块参照对象不存在"<br />     End If<br /> End Sub<br />

思路感觉是这样了。就是还有个报错不知道什么情况

liuhe

在 excel  编程不就行了

willj

liuhe 发表于 2023-9-11 10:45
在 excel  编程不就行了

可以出个示例学习下吗

chixun99

http://bbs.mjtd.com/forum.php?mo ... =%CA%F4%D0%D4%BF%E9去这个连接找找我回复的代码参考。

willj

chixun99 发表于 2023-9-11 11:32
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=186844&highlight=%CA%F4%D0%D4%BF%E9去这个连接找找我 ...

老师好，如果有时间是否可以帮我搞个示例。我查了下好像是需要用到GetDynamicBlockProperties方法去获取动态块的自定义属性，具体实现修改还未摸索出来。

chixun99

dim vAtt as variant
vAtt = AttBlR.GetAttributes
            If IsArray(vAtt) Then
                For i = 0 To UBound(vAtt)
                    If vAtt(i).TagString = BlName Then vAtt(i).TextString = ValueStr
                Next
            End If
就这段可以实现属性值的修改了？关键是要遍历所有你的图块图形，BlName 改为对应你的A列的名称，ValueStr改为对应你的B列的值

willj

chixun99 发表于 2023-9-11 12:33
dim vAtt as variant
vAtt = AttBlR.GetAttributes
            If IsArray(vAtt) Then

暂时无从下手

liuhe

willj 发表于 2023-9-11 13:06
暂时无从下手

你会VBA吗？看你的帖子和帐号，很多年的账号了，但是没有一个代码

willj

liuhe 发表于 2023-9-11 13:33
你会VBA吗？看你的帖子和帐号，很多年的账号了，但是没有一个代码

第一次连CAD进行操作

liuhe

willj 发表于 2023-9-11 13:45
第一次连CAD进行操作

你要是真会vba  直接查书就能解决的事情