[求助]如何创建带属性的块？
关于图块及块属性创建的示例
Public Sub BlockSample()On Error Resume Next
Dim bbbObj As AcadBlock
Set bbbObj = ThisDrawing.Blocks(3)
bbbObj.Delete
'在创建新块对象之前，Blocks中的块数量
MsgBox "创建新块之前的块数量为：" & ThisDrawing.Blocks.Count
'准备创建一个图块
Dim blkObj As AcadBlock
Dim insPnt(0 To 2) As Double
'设定图块对象的原点坐标
insPnt(0) = 0: insPnt(1) = 0: insPnt(2) = 0
'在Blocks集合中创建名为TestBlock1的块对象
Set blkObj = ThisDrawing.Blocks.Add(insPnt, "TestBlock1")
MsgBox "创建新块之后的块数量为：" & ThisDrawing.Blocks.Count
'-------------------------------------------------------------
'本段代码将在TestBlock1块对象中创建2个图元对象
Dim cirObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0: center(1) = 0: center(2) = 0
radius = 38
'创建一个圆对象
Set cirObj = blkObj.AddCircle(center, radius)
'将圆的颜色设为红色
cirObj.Color = acRed
Dim lineObj As AcadLine
Dim sPnt(0 To 2) As Double, ePnt(0 To 2) As Double
sPnt(0) = center(0): sPnt(1) = center(1): sPnt(2) = 0
ePnt(0) = center(0) + 60: ePnt(1) = center(1) + 80: ePnt(2) = 0
'创建一条直线
Set lineObj = blkObj.AddLine(sPnt, ePnt)
'-------------------------------------------------------------
'本段代码用来创建块属性
Dim attObj As AcadAttribute
Dim height As Double
Dim tag As String
Dim prompt As String
Dim value As String
'设定块属性在块空间中的位置
insPnt(0) = -10: insPnt(1) = -10: insPnt(2) = 0
'设定属性文字的高度
height = 7
'设定属性标签
tag = "AttTag1"
'设定属性提示值
prompt = ""
'设定属性值
value = "AttValue1"
'在块中创建属性对象
Set attObj = blkObj.AddAttribute(height, acAttributeModePreset, _
prompt, insPnt, tag, value)
'-------------------------------------------------------------
'本段代码将把TestBlock1块对象插入到模型空间
Dim blkRefObj As AcadBlockReference
Dim insertPnt(0 To 2) As Double
'指定模型空间的插入点
insertPnt(0) = 120: insertPnt(1) = 100: insertPnt(2) = 0
'插入图块
Set blkRefObj = ThisDrawing.ModelSpace.InsertBlock(insertPnt, _
"TestBlock1", 1#, 1#, 1#, 0#)
blkRefObj.Update
MsgBox ""
ThisDrawing.Regen True
'-------------------------------------------------------------
'本段代码让你选择是否将TestBlock1图块炸开
Dim YesNo As Integer
YesNo = MsgBox("你想将图块炸开吗？", vbYesNo)
If YesNo = vbYes Then
Dim entObjs As Variant
Dim I As Integer
'炸开块对象
entObjs = blkRefObj.Explode
'循环显示对象数组中的图元对象
For I = 0 To UBound(entObjs)
MsgBox "entObjs(" & I & ") = " & entObjs(I).ObjectName
Next
'删除原来的图块，只保留炸开的图元
blkRefObj.Delete
End If
End Sub
页:
[1]