保存图形为内部快的vba代码，
用一个指定图层的矩形，框住需要保存为块的图形，Sub CopyEntitiesToNewBlock()
Dim objSelectionSet As AcadSelectionSet
Dim objSelectionSet2 As AcadSelectionSet
Dim objBlock As AcadBlock
Dim objEntity As AcadEntity
Dim objEntityArray() As AcadEntity
Dim objEntityCopy As AcadEntity
Dim objBlockRef As AcadBlockReference
Dim Pt(0 To 2) As Double
Dim block_insert(0 To 2) As Double
Dim blkName As String
Dim minPt As Variant
Dim maxPt As Variant
Dim minPt1 As Variant
Dim maxPt1 As Variant
Dim insPt0 As Variant
Dim insPt1 As Variant
Dim layer_difine As Variant
Dim block_name_difine As Variant
Dim Insertion_Point() As Double
Dim star_point() As Double
'框选图层填写
layer_difine = "101"
'块的名字的图层
block_name_difine = "块名字"
'能识别的实体对象（单行文字，多行文字，直线，圆，圆弧，多段线，样条曲线，填充,椭圆或椭圆弧，）
On Error Resume Next
' 删除现有选择集，如果存在
ThisDrawing.SelectionSets.Item("MySelectionSet").Delete
ThisDrawing.SelectionSets.Item("MySelectionSet2").Delete
On Error GoTo 0
' 创建一个选择集
Set objSelectionSet = ThisDrawing.SelectionSets.Add("MySelectionSet")
Set objSelectionSet2 = ThisDrawing.SelectionSets.Add("MySelectionSet2")
' 选择要复制的对象
objSelectionSet.SelectOnScreen
' 如果没有选择任何对象，则退出子程序
If objSelectionSet.Count = 0 Then
MsgBox "未选择任何对象。"
objSelectionSet.Delete
Exit Sub
End If
' 遍历选择集中的实体并检查其图层
For Each objEntity In objSelectionSet
If objEntity.Layer = layer_difine Then
' 获取实体的最小点和最大点
objEntity.GetBoundingBox minPt, maxPt
Dim min_Pt0 As Variant
Dim min_Pt1 As Variant
Dim max_Pt0 As Variant
Dim max_Pt1 As Variant
min_Pt0 = minPt(0)
min_Pt1 = minPt(1)
max_Pt0 = maxPt(0)
max_Pt1 = maxPt(1)
' 遍历模型空间，查找插入点位于最小点和最大点之间的实体
Dim objEntity2 As Variant
ii = 0
For i = 0 To ModelSpace.Count - 1
Set objEntity2 = ModelSpace.Item(i)
' 检查实体类型，只添加支持的实体类型
If objEntity2.ObjectName = "AcDbMText" Or objEntity2.ObjectName = "AcDbText" Then
If objEntity2.Layer = block_name_difine Then
Insertion_Point = objEntity2.InsertionPoint
insPt0 = Insertion_Point(0)
insPt1 = Insertion_Point(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
block_name = objEntity2.TextString
GoTo NEXT_FOR
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
End If
Insertion_Point = objEntity2.InsertionPoint
insPt0 = Insertion_Point(0)
insPt1 = Insertion_Point(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf objEntity2.ObjectName = "AcDbLine" Then
star_point = objEntity2.StartPoint
insPt0 = star_point(0)
insPt1 = star_point(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf objEntity2.ObjectName = "AcDbCircle" Then
Dim objCircle As AcadCircle
Set objCircle = objEntity2
insPt0 = objCircle.Center(0)
insPt1 = objCircle.Center(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf objEntity2.ObjectName = "AcDbArc" Then
Dim objAcDbArc() As Double
objAcDbArc = objEntity2.StartPoint
insPt0 = objAcDbArc(0)
insPt1 = objAcDbArc(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf TypeName(objEntity2) = "IAcadLWPolyline" Then
' 获取多段线的坐标数组
Dim coords() As Double
coords = objEntity2.Coordinates
' 提取起点坐标
insPt0 = coords(0)
insPt1 = coords(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf objEntity2.ObjectName = "AcDbSpline" Then
Dim Fit_Points() As Double
Fit_Points = objEntity2.FitPoints
insPt0 = Fit_Points(0)
insPt1 = Fit_Points(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf TypeName(objEntity2) = "IAcadHatch" Then
objEntity2.GetBoundingBox minPt1, maxPt1
insPt0 = minPt1(0)
insPt1 = minPt1(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
ElseIf objEntity2.ObjectName = "AcDbEllipse" Then
star_point = objEntity2.StartPoint
insPt0 = star_point(0)
insPt1 = star_point(1)
If Abs(insPt0) > Abs(min_Pt0) And Abs(insPt0) < Abs(max_Pt0) And Abs(insPt1) < Abs(max_Pt1) And Abs(insPt1) > Abs(min_Pt1) Then
ReDim Preserve objEntityArray(ii) ' 使用 ReDim Preserve 来重新调整数组大小
Set objEntityArray(ii) = ModelSpace.Item(i)
ii = ii + 1
End If
End If
NEXT_FOR:
Next i
' 定义新的块名称
blkName = block_name
' 遍历当前图纸中的所有块定义
For Each blkDef In ThisDrawing.Blocks
' 检查块的名称
If blkDef.Name = blkName Then
' 如果找到了匹配的块定义，设置标志为True，并删除它
isFound = True
blkDef.Delete
Exit For
End If
Next
' 设置块原点
Pt(0) = (max_Pt0 + min_Pt0) / 2: Pt(1) = (min_Pt1 + max_Pt1) / 2: Pt(2) = 0
' 设置块插入点
block_insert(0) = (max_Pt0 + min_Pt0) / 2
block_insert(1) = ((min_Pt1 + max_Pt1) / 2) - (max_Pt1 - min_Pt1)
block_insert(2) = 0
' 创建一个新的块
Set objBlock = ThisDrawing.Blocks.Add(Pt, blkName)
' 将对象数组的副本添加到新的块中
ThisDrawing.CopyObjects objEntityArray, objBlock
' 在模型空间中插入新创建的块，插入点为最小点
Set objBlockRef = ThisDrawing.ModelSpace.InsertBlock(block_insert, blkName, 1, 1, 1, 0)
End If
Next objEntity
' 删除原始实体
objSelectionSet.Clear
ThisDrawing.Regen acAllViewports
MsgBox "已成功创建新块 " & blkName & " 并将其插入到模型空间。"
End Sub
页:
[1]