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

willj · 发表于 2023-9-12 10:16

本帖最后由 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

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:11

本帖最后由 chixun99 于 2023-9-12 14:12 编辑

For Each objBlockRef In objBlockRefs 中的 objBlockRefs 改为选择集，把图纸中的所有图块选到选择集中。
代码中的objBlockRefs这个变量未赋值。

willj · 发表于 2023-9-12 19:07

本帖最后由 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

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

chixun99 · 发表于 2023-9-13 09:47

Set MyObj = acadModelSpace.Item(7)这个是整个模型空间（modelspace）中序号7的图元，刚好能蒙到也行吧。其实所有图元就是一个集合（对象），加个循环遍历所有图元，判断是块参照类型、块名（动态块需要用EffectiveName属性来对比）一致就可以了。
cad vba简单，多用就熟悉了。

小捷 · 发表于 2023-9-13 11:33

电梯老表，同行呀

willj · 发表于 2023-9-13 15:36

本帖最后由 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

'循环遍历所有块参照对象 
    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

chixun99 · 发表于 2023-9-14 11:55

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

恭喜又多一个入坑的。

sunny_8848 · 发表于 2023-9-14 16:24

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

请教下，感觉代码不齐全？

willj · 发表于 2023-9-15 08:25

sunny_8848 发表于 2023-9-14 16:24
请教下，感觉代码不齐全？

结合上文就齐了

Myday · 发表于 2023-12-1 20:59

我也研究一下动态块

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

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

本帖子中包含更多资源