来一个vba选择集的块属性炸开，保留属性值
以下是本人在VBA吧里发的原创代码放到这里来增加人气。大家共同学习进步‘本代码把选择集中的属性块炸开，并把属性值转为单行文字插入到原属性的位置；
Sub 炸属性块()
Dim ss As AcadSelectionSet '选择集
Dim ssbl As AcadSelectionSet '选择集
Dim bl As AcadBlockReference '块引用（块插入）
Dim acEn As AcadEntity '图元对象
Dim acTxt As AcadText '文本对象
Dim arAtt As Variant '块属性数组
Dim arP As Variant '插入点变量数组
Dim Xsc As Double 'x块比例
Dim Ysc As Double 'y块比例
Dim Zsc As Double 'z轴比例
Dim AnRotate As Double '块旋转角度
Dim iP(2) As Double '块插入点
Dim aP(2) As Double '块属性参照点
Dim strAttributes As String '属性文字串
Dim i As Integer '计数器
Dim strTag As String '文本标签
Set ss = newSel_set("aBlock")
ThisDrawing.Utility.Prompt "选择一个属性块插入:"
ss.SelectOnScreen
If ThisDrawing.ActiveSpace = acPaperSpace Then MsgBox "请在模型空间选择块"
If ss.Count > 0 Then
If ss(0).ObjectName = Dr17 Then
'================================================================
'========以下是把属性块炸开又能保留原来的属性值内容。=================
'========先用字典记录所有属性值对应属性名称然后在原来位置填写文字=======
'========所有属性遍历完后，删除属性块===============================
'================================================================
'读取块参照的插入点、缩放比例、选择角度
Set bl = ss(0)
arAtt = bl.InsertionPoint '读取插入点到变量
iP(0) = arAtt(0): iP(1) = arAtt(1): iP(2) = arAtt(2)
AnRotate = bl.Rotation
Xsc = bl.XScaleFactor: Ysc = bl.YScaleFactor: Zsc = bl.ZScaleFactor
'读块属性参照的成员信息
arAtt = bl.GetAttributes '读取块属性到变量
If UBound(arAtt) >= 0 Then
For i = LBound(arAtt) To UBound(arAtt)
With arAtt(i)
If .TextString <> "" And Not (.Invisible) Then '内容文字串不为空且非隐藏属性
Set acTxt = ThisDrawing.ModelSpace.AddText(.TextString, iP, .Height) '添加文字在插入点设置字高
acTxt.Alignment = .Alignment '对齐方式
acTxt.Backward = .Backward '正向 / 反向
acTxt.ScaleFactor = .ScaleFactor '字宽比例
acTxt.Layer = .Layer '图层
acTxt.ObliqueAngle = .ObliqueAngle '倾斜角
acTxt.Rotation = .Rotation '旋转
acTxt.StyleName = .StyleName '样式名
acTxt.TrueColor = .TrueColor '颜色
acTxt.UpsideDown = .UpsideDown '颠倒
strTag = .TagString '标签文字串
'arP = .InsertionPoint '插入点坐标
arP = .TextAlignmentPoint '对齐点坐标
aP(0) = arP(0) + iP(0): aP(1) = arP(1) + iP(1): aP(2) = arP(2) + iP(2)
Call acTxt.Move(iP, aP)
End If
End With
'strAttributes = strAttributes & vbLf & " Tag: " & arAtt(i).TagString & _
' vbLf & " Value: " & arAtt(i).TextString & vbLf & " "
Next
'MsgBox "The attributes for blockReference " & bl.Name & " are: " & strAttributes, , "GetAttributes Example"
Else
Debug.Print "块没有定义属性。"
End If
'炸开块参照并删除其中炸开的图形中属于属性定义的图元，并最后删除选定的块
'Set ssbl = newSel_set("arBlen")
arP = bl.Explode
If UBound(arP) > 0 Then
For i = UBound(arP) To 0 Step -1
'Debug.Print arP(i).ObjectName
If arP(i).ObjectName = Dr17 Or arP(i).ObjectName = Dr18 Then
arP(i).Delete
End If
Next i
End If
ss(0).Delete
Else
Debug.Print "选择图形不是图块。"
End If
Else
Debug.Print "未选择图块"
End If
End Sub
vb这语法，看了前面17行已经不想往下看了 d1742647821 发表于 2023-4-18 11:47
vb这语法，看了前面17行已经不想往下看了
大神现在用哪个语言？语法是没法改啊，只能换语种。 为了避免看过多代码，我把思路补上吧。其实类似下边这个伪代码的流程而已。
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 burst快捷键ET工具箱
页:
[1]