VBA如何用选择集定义块

gaba

求助：VBA可以用block.add的方法定义块中的实体，请教：VBA方法如何用图形中已有的实体即选择集来确定块中的对象？

alin

copyobjects

gaba

难道还要通过一个转换成XRef块的过程？

alin

查查帮助文件Copyobjects方法的用法。你的要求只是把模型或图纸空间里的对象拷贝到图块空间里。

wylong

下面的为vb中的源码，稍加改动就可在vba中使用。附件为vb源文件

2. Option Explicit
3. Dim SSet As Object
4. Dim ptBase As Variant
5. Dim strPath As String
6. Private Sub CmdCancle_Click()
7.     Unload Me
8. End Sub
9. Private Sub CmdOK_Click()
10.     If Trim(TxtBlockName.Text) = "" Then
11.         If MsgBox("请输入图块名称", vbCritical + vbOKOnly, AppName) = vbOK Then Exit Sub
12.     End If
13.    
14.     Me.Hide
15.    
16.     ' 提示用户输入块定义的名称
17.     'Dim strName As String
18.     'strName = ThisDrawing.Utility.GetString(True, vbCrLf & "输入块的名称:")
19.         
20.     ' 获得相对路径
21.     strPath = App.Path & "\BlockLib" & ComFolderName & "" & Trim(TxtBlockName) & ".dwg"
22.     'strPath = App.Path & "\BlockLib" & Trim(TxtBlockName) & ".dwg"
23.    
24.     ' 将所有的实体移动到原点附近，确保块定义的插入点无误
25.     'Dim ptOrigin(0 To 2) As Double
26.     'ptOrigin(0) = 0: ptOrigin(1) = 0: ptOrigin(2) = 0
27.     'Dim Ent As OBJECT
28.     'For Each Ent In SSet
29.     '    Ent.Move ptBase, ptOrigin
30.     'Next
31.    
32.     ' 将块定义导出
33.     'ThisDrawing.Wblock strPath, SSet   ' 使用此方法创建的块没有浏览缩略图
34.    
35.     ThisDrawing.SetVariable "FILEDIA", 0
36.    
37.     ' 将块定义导出
38.     ThisDrawing.SendCommand "-WBLOCK" & vbLf & strPath & vbLf & vbLf & axPoint2lspPoint(ptBase) & vbLf & axSSet2lspEnts(SSet) & vbLf & vbLf
39.    
40.     Call CmdOKNextCode
41. End Sub
42. Private Sub CmdOKNextCode()
43.     ThisDrawing.SetVariable "FILEDIA", 1
44.    
45.     If OptNoChange.Value Then
46.         'For Each Ent In SSet
47.         '    Ent.Move ptOrigin, ptBase
48.         'Next
49.     End If
50.    
51.     If OptDelect.Value Then
52.         ' 删除图形中绘制的所有对象
53.         SSet.Delete
54.     End If
55.    
56.     If OptBlock.Value Then
57.    
58.         ' 删除图形中绘制的所有对象
59.         'SSet.Erase
60.         SSet.Delete
61.         
62.         Dim ObjBlock As Object
63.         Set ObjBlock = ThisDrawing.ModelSpace.InsertBlock(ptBase, strPath, 1, 1, 1, 0)
64.     End If
65.    
66.     Set SSet = Nothing
67.    
68.     Unload Me
69. End Sub
70. Private Sub Command1_Click()
71.     Unload Me
72. End Sub
73. Private Sub CmdPickPoint_Click()
74.     Me.Hide
75.    
76.     ' 提示用户输入块定义的基点
77.     ptBase = ThisDrawing.Utility.GetPoint(, vbCrLf & "拾取基点:")
78.    
79.     Me.Show
80. End Sub
81. Private Sub CmdSelectObjects_Click()
82.     Me.Hide
83.     Set SSet = GetSelectionSetObject
84.    
85.     Me.Show
86. End Sub
87. Private Sub Form_Load()
88.     On Error GoTo ErrHandle
89.    
90.     Dim Fso As Object
91.     Dim Fols As Object
92.     Dim Fol As Object
93.    
94.     Set Fso = CreateObject("Scripting.FileSystemObject")
95.     Set Fols = Fso.GetFolder(App.Path & "\BlockLib")
96.     For Each Fol In Fols.SubFolders
97.         ComFolderName.AddItem Fol.Name
98.     Next
99.    
100.     ComFolderName.ListIndex = 0
101.    
102.     Call GetAutoCADApplication(Me)
103.    
104.     Call MoveXWindowsCenter(Me)
105.    
106.     Set Fso = Nothing
107.     Set Fols = Nothing
108.    
109.     Exit Sub
110. ErrHandle:
111.     MsgBox Err.Description, vbCritical + vbOKOnly, AppName
112.     Err.Clear
113.     Unload Me
114. End Sub
115. Private Sub Form_KeyPress(KeyAscii As Integer)
116.     If KeyAscii = 27 Then '用户按了ESC键，退出
117.         Unload Me
118.     End If
119. End Sub
120. Private Sub TextFocus(ctl As Control) '定义过程
121.     ctl.SelStart = 0
122.     ctl.SelLength = Len(ctl.Text)
123. End Sub
124. Private Sub Text1_GotFocus()
125.     TextFocus Text1 '过程调用
126. End Sub
127. Public Property Set Application(ByVal vNewApplication As Object)
128.     Set AcadApp = vNewApplication
129. End Property
130. '转换点的函数
131. Public Function axPoint2lspPoint(Pnt As Variant) As String
132.     axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2)
133. End Function
134. '转换图元函数
135. Public Function axEnt2lspEnt(EntObj As Object) As String
136.     Dim entHandle As String
137.     entHandle = EntObj.Handle
138.     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
139. End Function
140. ' 转换多个图元的函数
141. Public Function axSSet2lspEnts(ByVal SSet As Object) As String
142.     If SSet.Count = 0 Then Exit Function
143.     Dim entHandle As String
144.     Dim strEnts As String
145.     entHandle = SSet.Item(0).Handle
146.     strEnts = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
147.    
148.     If SSet.Count > 1 Then
149.         Dim i As Integer
150.         For i = 1 To SSet.Count - 1
151.             entHandle = SSet.Item(i).Handle
152.             strEnts = strEnts & vbCr & "(handent " & Chr(34) & entHandle & Chr(34) & ")"
153.         Next i
154.     End If
155.    
156.     axSSet2lspEnts = strEnts
157. End Function

Option Explicit Dim SSet As Object Dim ptBase As Variant Dim strPath As String Private Sub CmdCancle_Click()     Unload Me End Sub Private Sub CmdOK_Click()     If Trim(TxtBlockName.Text) = "" Then         If MsgBox("请输入图块名称", vbCritical + vbOKOnly, AppName) = vbOK Then Exit Sub     End If         Me.Hide         ' 提示用户输入块定义的名称     'Dim strName As String     'strName = ThisDrawing.Utility.GetString(True, vbCrLf & "输入块的名称:")              ' 获得相对路径     strPath = App.Path & "\BlockLib" & ComFolderName & "" & Trim(TxtBlockName) & ".dwg"     'strPath = App.Path & "\BlockLib" & Trim(TxtBlockName) & ".dwg"         ' 将所有的实体移动到原点附近，确保块定义的插入点无误     'Dim ptOrigin(0 To 2) As Double     'ptOrigin(0) = 0: ptOrigin(1) = 0: ptOrigin(2) = 0     'Dim Ent As OBJECT     'For Each Ent In SSet     '    Ent.Move ptBase, ptOrigin     'Next         ' 将块定义导出     'ThisDrawing.Wblock strPath, SSet   ' 使用此方法创建的块没有浏览缩略图         ThisDrawing.SetVariable "FILEDIA", 0         ' 将块定义导出     ThisDrawing.SendCommand "-WBLOCK" & vbLf & strPath & vbLf & vbLf & axPoint2lspPoint(ptBase) & vbLf & axSSet2lspEnts(SSet) & vbLf & vbLf         Call CmdOKNextCode End Sub Private Sub CmdOKNextCode()     ThisDrawing.SetVariable "FILEDIA", 1         If OptNoChange.Value Then         'For Each Ent In SSet         '    Ent.Move ptOrigin, ptBase         'Next     End If         If OptDelect.Value Then         ' 删除图形中绘制的所有对象         SSet.Delete     End If         If OptBlock.Value Then             ' 删除图形中绘制的所有对象         'SSet.Erase         SSet.Delete                  Dim ObjBlock As Object         Set ObjBlock = ThisDrawing.ModelSpace.InsertBlock(ptBase, strPath, 1, 1, 1, 0)     End If         Set SSet = Nothing         Unload Me End Sub Private Sub Command1_Click()     Unload Me End Sub Private Sub CmdPickPoint_Click()     Me.Hide         ' 提示用户输入块定义的基点     ptBase = ThisDrawing.Utility.GetPoint(, vbCrLf & "拾取基点:")         Me.Show End Sub Private Sub CmdSelectObjects_Click()     Me.Hide     Set SSet = GetSelectionSetObject         Me.Show End Sub Private Sub Form_Load()     On Error GoTo ErrHandle         Dim Fso As Object     Dim Fols As Object     Dim Fol As Object         Set Fso = CreateObject("Scripting.FileSystemObject")     Set Fols = Fso.GetFolder(App.Path & "\BlockLib")     For Each Fol In Fols.SubFolders         ComFolderName.AddItem Fol.Name     Next         ComFolderName.ListIndex = 0         Call GetAutoCADApplication(Me)         Call MoveXWindowsCenter(Me)         Set Fso = Nothing     Set Fols = Nothing         Exit Sub ErrHandle:     MsgBox Err.Description, vbCritical + vbOKOnly, AppName     Err.Clear     Unload Me End Sub Private Sub Form_KeyPress(KeyAscii As Integer)     If KeyAscii = 27 Then '用户按了ESC键，退出         Unload Me     End If End Sub Private Sub TextFocus(ctl As Control) '定义过程     ctl.SelStart = 0     ctl.SelLength = Len(ctl.Text) End Sub Private Sub Text1_GotFocus()     TextFocus Text1 '过程调用 End Sub Public Property Set Application(ByVal vNewApplication As Object)     Set AcadApp = vNewApplication End Property '转换点的函数 Public Function axPoint2lspPoint(Pnt As Variant) As String     axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & "," & Pnt(2) End Function '转换图元函数 Public Function axEnt2lspEnt(EntObj As Object) As String     Dim entHandle As String     entHandle = EntObj.Handle     axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")" End Function ' 转换多个图元的函数 Public Function axSSet2lspEnts(ByVal SSet As Object) As String     If SSet.Count = 0 Then Exit Function     Dim entHandle As String     Dim strEnts As String     entHandle = SSet.Item(0).Handle     strEnts = "(handent " & Chr(34) & entHandle & Chr(34) & ")"         If SSet.Count > 1 Then         Dim i As Integer         For i = 1 To SSet.Count - 1             entHandle = SSet.Item(i).Handle             strEnts = strEnts & vbCr & "(handent " & Chr(34) & entHandle & Chr(34) & ")"         Next i     End If         axSSet2lspEnts = strEnts End Function

alin

这样更简单直接

http://discussion.autodesk.com/thread.jspa?messageID=384565

gaba

多谢！