来一个vba选择集的块属性炸开，保留属性值

chixun99

以下是本人在VBA吧里发的原创代码放到这里来增加人气。大家共同学习进步
‘本代码把选择集中的属性块炸开，并把属性值转为单行文字插入到原属性的位置；

2. Sub 炸属性块()
   
3. Dim ss As AcadSelectionSet '选择集
   
4. Dim ssbl As AcadSelectionSet '选择集
   
5. Dim bl As AcadBlockReference '块引用（块插入）
   
6. Dim acEn As AcadEntity '图元对象
   
7. Dim acTxt As AcadText '文本对象
   
8. Dim arAtt As Variant '块属性数组
   
9. Dim arP As Variant '插入点变量数组
   
10. Dim Xsc As Double 'x块比例
    
11. Dim Ysc As Double 'y块比例
    
12. Dim Zsc As Double 'z轴比例
    
13. Dim AnRotate As Double '块旋转角度
    
14. Dim iP(2) As Double '块插入点
    
15. Dim aP(2) As Double '块属性参照点
    
16. Dim strAttributes As String '属性文字串
    
17. Dim i As Integer '计数器
    
18. Dim strTag As String '文本标签
    
19. 
    
20. Set ss = newSel_set("aBlock")
    
21. ThisDrawing.Utility.Prompt "选择一个属性块插入:"
    
22. ss.SelectOnScreen
    
23. 
    
24. If ThisDrawing.ActiveSpace = acPaperSpace Then MsgBox "请在模型空间选择块"
    
25. If ss.Count > 0 Then
    
26. If ss(0).ObjectName = Dr17 Then
    
27. '================================================================
    
28. '========以下是把属性块炸开又能保留原来的属性值内容。=================
    
29. '========先用字典记录所有属性值对应属性名称然后在原来位置填写文字=======
    
30. '========所有属性遍历完后，删除属性块===============================
    
31. '================================================================
    
32. '读取块参照的插入点、缩放比例、选择角度
    
33. Set bl = ss(0)
    
34. arAtt = bl.InsertionPoint '读取插入点到变量
    
35. iP(0) = arAtt(0): iP(1) = arAtt(1): iP(2) = arAtt(2)
    
36. AnRotate = bl.Rotation
    
37. Xsc = bl.XScaleFactor: Ysc = bl.YScaleFactor: Zsc = bl.ZScaleFactor
    
38. '读块属性参照的成员信息
    
39. arAtt = bl.GetAttributes '读取块属性到变量
    
40. If UBound(arAtt) >= 0 Then
    
41. For i = LBound(arAtt) To UBound(arAtt)
    
42. With arAtt(i)
    
43. If .TextString <> "" And Not (.Invisible) Then '内容文字串不为空且非隐藏属性
    
44. Set acTxt = ThisDrawing.ModelSpace.AddText(.TextString, iP, .Height) '添加文字在插入点设置字高
    
45. acTxt.Alignment = .Alignment '对齐方式
    
46. acTxt.Backward = .Backward '正向 / 反向
    
47. acTxt.ScaleFactor = .ScaleFactor '字宽比例
    
48. acTxt.Layer = .Layer '图层
    
49. acTxt.ObliqueAngle = .ObliqueAngle '倾斜角
    
50. acTxt.Rotation = .Rotation '旋转
    
51. acTxt.StyleName = .StyleName '样式名
    
52. acTxt.TrueColor = .TrueColor '颜色
    
53. acTxt.UpsideDown = .UpsideDown '颠倒
    
54. strTag = .TagString '标签文字串
    
55. 'arP = .InsertionPoint '插入点坐标
    
56. arP = .TextAlignmentPoint '对齐点坐标
    
57. aP(0) = arP(0) + iP(0): aP(1) = arP(1) + iP(1): aP(2) = arP(2) + iP(2)
    
58. Call acTxt.Move(iP, aP)
    
59. End If
    
60. End With
    
61. 'strAttributes = strAttributes & vbLf & " Tag: " & arAtt(i).TagString & _
    
62. ' vbLf & " Value: " & arAtt(i).TextString & vbLf & " "
    
63. Next
    
64. 'MsgBox "The attributes for blockReference " & bl.Name & " are: " & strAttributes, , "GetAttributes Example"
    
65. Else
    
66. Debug.Print "块没有定义属性。"
    
67. End If
    
68. '炸开块参照并删除其中炸开的图形中属于属性定义的图元，并最后删除选定的块
    
69. 'Set ssbl = newSel_set("arBlen")
    
70. arP = bl.Explode
    
71. If UBound(arP) > 0 Then
    
72. For i = UBound(arP) To 0 Step -1
    
73. 'Debug.Print arP(i).ObjectName
    
74. If arP(i).ObjectName = Dr17 Or arP(i).ObjectName = Dr18 Then
    
75. arP(i).Delete
    
76. End If
    
77. Next i
    
78. End If
    
79. ss(0).Delete
    
80. Else
    
81. Debug.Print "选择图形不是图块。"
    
82. End If
    
83. Else
    
84. Debug.Print "未选择图块"
    
85. End If
    
86. End Sub

Sub 炸属性块()<br /> Dim ss As AcadSelectionSet '选择集<br /> Dim ssbl As AcadSelectionSet '选择集<br /> Dim bl As AcadBlockReference '块引用（块插入）<br /> Dim acEn As AcadEntity '图元对象<br /> Dim acTxt As AcadText '文本对象<br /> Dim arAtt As Variant '块属性数组<br /> Dim arP As Variant '插入点变量数组<br /> Dim Xsc As Double 'x块比例<br /> Dim Ysc As Double 'y块比例<br /> Dim Zsc As Double 'z轴比例<br /> Dim AnRotate As Double '块旋转角度<br /> Dim iP(2) As Double '块插入点<br /> Dim aP(2) As Double '块属性参照点<br /> Dim strAttributes As String '属性文字串<br /> Dim i As Integer '计数器<br /> Dim strTag As String '文本标签<br /> <br /> Set ss = newSel_set("aBlock")<br /> ThisDrawing.Utility.Prompt "选择一个属性块插入:"<br /> ss.SelectOnScreen<br /> <br /> If ThisDrawing.ActiveSpace = acPaperSpace Then MsgBox "请在模型空间选择块"<br /> If ss.Count > 0 Then<br /> If ss(0).ObjectName = Dr17 Then<br /> '================================================================<br /> '========以下是把属性块炸开又能保留原来的属性值内容。=================<br /> '========先用字典记录所有属性值对应属性名称然后在原来位置填写文字=======<br /> '========所有属性遍历完后，删除属性块===============================<br /> '================================================================<br /> '读取块参照的插入点、缩放比例、选择角度<br /> Set bl = ss(0)<br /> arAtt = bl.InsertionPoint '读取插入点到变量<br /> iP(0) = arAtt(0): iP(1) = arAtt(1): iP(2) = arAtt(2)<br /> AnRotate = bl.Rotation<br /> Xsc = bl.XScaleFactor: Ysc = bl.YScaleFactor: Zsc = bl.ZScaleFactor<br /> '读块属性参照的成员信息<br /> arAtt = bl.GetAttributes '读取块属性到变量<br /> If UBound(arAtt) >= 0 Then<br /> For i = LBound(arAtt) To UBound(arAtt)<br /> With arAtt(i)<br /> If .TextString <> "" And Not (.Invisible) Then '内容文字串不为空且非隐藏属性<br /> Set acTxt = ThisDrawing.ModelSpace.AddText(.TextString, iP, .Height) '添加文字在插入点设置字高<br /> acTxt.Alignment = .Alignment '对齐方式<br /> acTxt.Backward = .Backward '正向 / 反向<br /> acTxt.ScaleFactor = .ScaleFactor '字宽比例<br /> acTxt.Layer = .Layer '图层<br /> acTxt.ObliqueAngle = .ObliqueAngle '倾斜角<br /> acTxt.Rotation = .Rotation '旋转<br /> acTxt.StyleName = .StyleName '样式名<br /> acTxt.TrueColor = .TrueColor '颜色<br /> acTxt.UpsideDown = .UpsideDown '颠倒<br /> strTag = .TagString '标签文字串<br /> 'arP = .InsertionPoint '插入点坐标<br /> arP = .TextAlignmentPoint '对齐点坐标<br /> aP(0) = arP(0) + iP(0): aP(1) = arP(1) + iP(1): aP(2) = arP(2) + iP(2)<br /> Call acTxt.Move(iP, aP)<br /> End If<br /> End With<br /> 'strAttributes = strAttributes & vbLf & " Tag: " & arAtt(i).TagString & _<br /> ' vbLf & " Value: " & arAtt(i).TextString & vbLf & " "<br /> Next<br /> 'MsgBox "The attributes for blockReference " & bl.Name & " are: " & strAttributes, , "GetAttributes Example"<br /> Else<br /> Debug.Print "块没有定义属性。"<br /> End If<br /> '炸开块参照并删除其中炸开的图形中属于属性定义的图元，并最后删除选定的块<br /> 'Set ssbl = newSel_set("arBlen")<br /> arP = bl.Explode<br /> If UBound(arP) > 0 Then<br /> For i = UBound(arP) To 0 Step -1<br /> 'Debug.Print arP(i).ObjectName<br /> If arP(i).ObjectName = Dr17 Or arP(i).ObjectName = Dr18 Then<br /> arP(i).Delete<br /> End If<br /> Next i<br /> End If<br /> ss(0).Delete<br /> Else<br /> Debug.Print "选择图形不是图块。"<br /> End If<br /> Else<br /> Debug.Print "未选择图块"<br /> End If<br /> End Sub

liuhe

burst  快捷键  ET工具箱

d1742647821

vb这语法，看了前面17行已经不想往下看了

chixun99

d1742647821 发表于 2023-4-18 11:47
vb这语法，看了前面17行已经不想往下看了

大神现在用哪个语言？语法是没法改啊，只能换语种。

chixun99

为了避免看过多代码，我把思路补上吧。其实类似下边这个伪代码的流程而已。
Sub 炸属性块()
Dim ss As AcadSelectionSet
Set ss = newSel_set("aBlock")
ThisDrawing.Utility.Prompt "选择一个属性块插入:"
ss.SelectOnScreen
If ss.Count > 0 Then
If ss(0).ObjectName = "acdb" Then
’这里还在想怎么能把属性块炸开又能保留原来的属性值内容。
’先用字典记录所有属性值对应属性名称然后在原来位置填写文字
‘所有属性遍历完后，删除属性块
（核心算法其实就是这里三段）……
Else
MsgBox "选择图形不是图块"
End If
Else
MsgBox "未选择图块"
End If
End Sub