VBA如何用选择集定义块
求助：VBA可以用block.add的方法定义块中的实体，请教：VBA方法如何用图形中已有的实体即选择集来确定块中的对象？ copyobjects 难道还要通过一个转换成XRef块的过程？ <p>查查帮助文件Copyobjects方法的用法。你的要求只是把模型或图纸空间里的对象拷贝到图块空间里。</p> 本帖最后由 作者 于 2010-5-21 10:39:17 编辑下面的为vb中的源码，稍加改动就可在vba中使用。附件为vb源文件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
<p>这样更简单直接</p><p><a href="http://discussion.autodesk.com/thread.jspa?messageID=384565">http://discussion.autodesk.com/thread.jspa?messageID=384565</a></p> 多谢！
页:
[1]