VBA如何用选择集定义块

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

xhi55dhyc3y.JPG