[求助]请教如何用VBA生成一个带属性的匿名块
如题，请赐教。Sub InstBlk()
'插入一个含有自定义属性的匿名块
'添加一个圆
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "*U")
Dim circleObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0: center(1) = 0: center(2) = 0
radius = 1
Set circleObj = blockObj.AddCircle(center, radius)
'添加一个属性
Dim attributeObj As AcadAttribute
Dim height As Double
Dim mode As Long
Dim prompt As String
Dim insertionPoint(0 To 2) As Double
Dim tag As String
Dim value As String
' 定义属性定义
height = 1#
mode = acAttributeModeNormal
prompt = "新提示"
insertionPoint(0) = 0#: insertionPoint(1) = 0#: insertionPoint(2) = 0
tag = "新标签"
value = "显示的属性值"
' 在模型空间中创建属性定义对象
Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insertionPoint, tag, value)
attributeObj.Invisible = False
attributeObj.Alignment = acAlignmentMiddleCenter
Dim BlkName As String
BlkName = GetUNBlock
Dim blockRefObj As AcadBlockReference
insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, BlkName, 1#, 1#, 1#, 0)
End Sub
Public Function GetUNBlock() As String
Dim blockObj As AcadBlock
Dim n As Integer
For Each blockObj In ThisDrawing.Blocks
If Left(blockObj.Name, 1) = "*" Then
If blockObj.Name"*Model_Space" And Left(blockObj.Name, 12)"*Paper_Space" Then
If Mid(blockObj.Name, 3) >= n Then
n = Mid(blockObj.Name, 3)
GetUNBlock = blockObj.Name
End If
End If
End If
Next
Set blockObj = Nothing
End Function
页:
[1]