[求助]请教如何用VBA生成一个带属性的匿名块

clement

如题，请赐教。

徐亚龙

2. Sub InstBlk()
   
3.     '插入一个含有自定义属性的匿名块
   
4.     '添加一个圆
   
5.     Dim blockObj As AcadBlock
   
6.     Dim insertionPnt(0 To 2) As Double
   
7.     insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
   
8.     Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "*U")
   
9.     Dim circleObj As AcadCircle
   
10.     Dim center(0 To 2) As Double
    
11.     Dim radius As Double
    
12.     center(0) = 0: center(1) = 0: center(2) = 0
    
13.     radius = 1
    
14.     Set circleObj = blockObj.AddCircle(center, radius)
    
15.     '添加一个属性
    
16.     Dim attributeObj As AcadAttribute
    
17.     Dim height As Double
    
18.     Dim mode As Long
    
19.     Dim prompt As String
    
20.     Dim insertionPoint(0 To 2) As Double
    
21.     Dim tag As String
    
22.     Dim value As String
    
23.     ' 定义属性定义
    
24.     height = 1#
    
25.     mode = acAttributeModeNormal
    
26.     prompt = "新提示"
    
27.     insertionPoint(0) = 0#: insertionPoint(1) = 0#: insertionPoint(2) = 0
    
28.     tag = "新标签"
    
29.     value = "显示的属性值"
    
30.     ' 在模型空间中创建属性定义对象
    
31.     Set attributeObj = blockObj.AddAttribute(height, mode, prompt, insertionPoint, tag, value)
    
32.     attributeObj.Invisible = False
    
33.     attributeObj.Alignment = acAlignmentMiddleCenter
    
34.     Dim BlkName As String
    
35.     BlkName = GetUNBlock
    
36.     Dim blockRefObj As AcadBlockReference
    
37.     insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
    
38.     Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, BlkName, 1#, 1#, 1#, 0)
    
39. End Sub
    
40. Public Function GetUNBlock() As String
    
41.     Dim blockObj As AcadBlock
    
42.     Dim n As Integer
    
43.     For Each blockObj In ThisDrawing.Blocks
    
44.         If Left(blockObj.Name, 1) = "*" Then
    
45.             If blockObj.Name <> "*Model_Space" And Left(blockObj.Name, 12) <> "*Paper_Space" Then
    
46.                 If Mid(blockObj.Name, 3) >= n Then
    
47.                     n = Mid(blockObj.Name, 3)
    
48.                     GetUNBlock = blockObj.Name
    
49.                 End If
    
50.             End If
    
51.         End If
    
52.     Next
    
53.     Set blockObj = Nothing
    
54. End Function
    

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

bluelover