以下是本人在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
|