根据用户选择的对象创建块定义
本帖最后由 QWQWQWQ 于 2022-11-29 19:56 编辑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
谢谢分享。
谢谢楼主分享 这杂用？看样子不是lisp？我是小白勿喷。。。 能力有限，完全看不懂！
页:
[1]