明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1025|回复: 4

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

[复制链接]
发表于 2023-4-18 11:31:26 | 显示全部楼层 |阅读模式
以下是本人在VBA吧里发的原创代码放到这里来增加人气。大家共同学习进步
‘本代码把选择集中的属性块炸开,并把属性值转为单行文字插入到原属性的位置;
  1. Sub 炸属性块()
  2. Dim ss As AcadSelectionSet '选择集
  3. Dim ssbl As AcadSelectionSet '选择集
  4. Dim bl As AcadBlockReference '块引用(块插入)
  5. Dim acEn As AcadEntity '图元对象
  6. Dim acTxt As AcadText '文本对象
  7. Dim arAtt As Variant '块属性数组
  8. Dim arP As Variant '插入点变量数组
  9. Dim Xsc As Double 'x块比例
  10. Dim Ysc As Double 'y块比例
  11. Dim Zsc As Double 'z轴比例
  12. Dim AnRotate As Double '块旋转角度
  13. Dim iP(2) As Double '块插入点
  14. Dim aP(2) As Double '块属性参照点
  15. Dim strAttributes As String '属性文字串
  16. Dim i As Integer '计数器
  17. Dim strTag As String '文本标签

  18. Set ss = newSel_set("aBlock")
  19. ThisDrawing.Utility.Prompt "选择一个属性块插入:"
  20. ss.SelectOnScreen

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



评分

参与人数 1明经币 +1 收起 理由
bssurvey + 1 赞一个!

查看全部评分

发表于 2023-4-18 11:47:44 | 显示全部楼层
vb这语法,看了前面17行已经不想往下看了
 楼主| 发表于 2023-4-18 11:58:08 | 显示全部楼层
d1742647821 发表于 2023-4-18 11:47
vb这语法,看了前面17行已经不想往下看了

大神现在用哪个语言?语法是没法改啊,只能换语种。
 楼主| 发表于 2023-4-18 12:07:11 | 显示全部楼层
为了避免看过多代码,我把思路补上吧。其实类似下边这个伪代码的流程而已。
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
发表于 2023-4-18 13:41:16 | 显示全部楼层
burst  快捷键  ET工具箱
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-22 18:37 , Processed in 0.176652 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表