保存图形为内部快的vba代码，

314611967

用一个指定图层的矩形，框住需要保存为块的图形，


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