根据用户选择的对象创建块定义

QWQWQWQ

Option Explicit

' 根据用户选择的对象创建块定义
Public Sub CreateBlkDef()
    ' 安全创建选择集
    On Error Resume Next
    Dim SSet As AcadSelectionSet
    If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then
        Set SSet = ThisDrawing.SelectionSets.Item("Example")
        SSet.Delete
    End If
    Set SSet = ThisDrawing.SelectionSets.Add("Example")
   
    ' 提示用户选择对象
    SSet.SelectOnScreen
   
    ' 选择基点
    Dim ptBase As Variant
    ptBase = ThisDrawing.Utility.GetPoint(, "拾取基点:")
   
    ' 创建块定义
    Dim objBlkDef As AcadBlock
    If HasBlkDef("SelectionSet") Then
        Call DeleteBlkDef("SelectionSet")
    End If
    Set objBlkDef = ThisDrawing.Blocks.Add(ptBase, "SelectionSet")
   
    ' 将选择集中的实体添加到数组中
    Dim objCollection() As Object
    ReDim objCollection(SSet.Count - 1)
    Dim i As Integer
    For i = 0 To SSet.Count - 1
        Set objCollection(i) = SSet.Item(i)
    Next i
   
    ' 将数组中的实体复制到块定义中
    ThisDrawing.CopyObjects objCollection, objBlkDef
   
    SSet.Delete         '及时删除不用的选择集非常重要
End Sub

' 模拟动态插入块的效果
Public Sub InsertBlock()
    ' 提示用户输入块定义的名称
    Dim blkName As String
    blkName = ThisDrawing.Utility.GetString(False, "输入块参照的名称:")
   
    ' 插入块参照
    If HasBlkDef(blkName) Then
        Dim strLeft As String, strRight As String
        strLeft = "(command ""-insert"" """
        strRight = """ pause """" """" """") "
        'MsgBox strLeft & blkName & strRight
        ' 完整语句示例：(command "-insert" "SelectionSet" pause "" "" "")
        ThisDrawing.SendCommand strLeft & blkName & strRight
    End If
End Sub

' 从图形中删除一个块定义
Private Sub DeleteBlkDef(ByVal blkName As String)
    ' 删除该块在图形中所有的块参照
    Dim objBlkRef As AcadBlockReference
    For Each objBlkRef In ThisDrawing.ModelSpace
        If StrComp(objBlkRef.Name, blkName) = 0 Then
            objBlkRef.Delete
        End If
    Next objBlkRef
   
    ' 删除块定义
    ThisDrawing.Blocks.Item(blkName).Delete
End Sub

' 当前图形中是否包含指定名称的块定义
Private Function HasBlkDef(ByVal blkName As String) As Boolean
    On Error Resume Next
   
    Dim objBlkDef As AcadBlock
    Set objBlkDef = ThisDrawing.Blocks.Item(blkName)
   
    ' 利用错误机制来判断是否包含指定的块定义
    If Err Then
        HasBlkDef = False
    Else
        HasBlkDef = True
    End If
End Function

' 复制外部图形中的实体到当前的图形中
Public Sub CopyFromOuterDwg()
    ' 判断图形是否存在
    If Len(Dir("C:\test.dwg")) = 0 Then
        MsgBox "指定的图形不存在！", vbCritical
        Exit Sub
    End If
   
    ' 保存目前的文档
    Dim objCurDoc As AcadDocument
    Set objCurDoc = ThisDrawing.Application.ActiveDocument
   
    ' 打开一个新图形
    Dim objNewDoc As AcadDocument
    Set objNewDoc = ThisDrawing.Application.Documents.Open("C:\test.dwg")

    ' 将当前图形（实际上是新打开的图形test.dwg）的实体复制到其他图形
    Dim objCollection(0 To 1) As Object
    Set objCollection(0) = objNewDoc.ModelSpace.Item(0)
    Set objCollection(1) = objNewDoc.ModelSpace.Item(1)
    objNewDoc.CopyObjects objCollection, objCurDoc.ModelSpace
   
    ' 关闭打开的图形
    objNewDoc.Close
End Sub

中国梦

谢谢分享。

中国梦

谢谢楼主分享

dazuyishi1314

这杂用？看样子不是lisp？我是小白勿喷。。。

guobao1985

能力有限，完全看不懂！