缩放视口

Public Sub VPzXP()
      On Error GoTo ERR_CONTROL
      Dim vp As AcadPViewport
      Dim N As Double
      Dim gpCode(0) As Integer
      Dim dataValue(0) As Variant
      Dim OBJSELSET As AcadSelectionSet
      gpCode(0) = 0
      dataValue(0) = "VIEWPORT"
      Set OBJSELSET = ThisDrawing.SelectionSets.Add("VPL")
      OBJSELSET.Select acSelectionSetAll, , , gpCode, dataValue
      
      For Each vp In OBJSELSET
            If vp.DisplayLocked = True Then
                  vp.DisplayLocked = False
            End If
            ThisDrawing.MSpace = True
            ZoomExtents
            N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
            N = 1 / N
            ZoomScaled N, 2
            ThisDrawing.MSpace = False
            vp.DisplayLocked = True
         Next
Exit_Here:
      Exit Sub
ERR_CONTROL:
      Select Case Err.Number
            Case "-2145320851"
                  ThisDrawing.SelectionSets.Item("VPL").Delete
                  Err.Clear
                  Resume
            Case Else
                  MsgBox Err.Number
                  Err.Clear
                  Resume Exit_Here
      End Select
End Sub

Public Sub VPzXP2()
  
      Dim oLayout As AcadLayout
      Dim oLayouts As AcadLayouts
      Dim B As AcadBlock
      Dim Ent As AcadEntity
      Dim vp As AcadPViewport
      Dim N As Double
      Set oLayouts = ThisDrawing.Layouts
      For Each oLayout In oLayouts
          If UCase(oLayout.Name) = "MODEL" Then GoTo skip
          Set B = oLayout.Block
            For Each Ent In B
                If Not TypeOf Ent Is AcadPViewport Then GoTo skipEnts
                If Ent.ObjectID = B(0).ObjectID Then GoTo skipEnts
                Set vp = Ent
                If vp.DisplayLocked = True Then
                      vp.DisplayLocked = False
                End If
                ThisDrawing.ActiveLayout = oLayout
                vp.Display True
                ThisDrawing.MSpace = True
                ZoomExtents
                N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
                N = 1 / N
                ZoomScaled N, 2
                ThisDrawing.MSpace = False
                vp.DisplayLocked = True
skipEnts:
            Next Ent
skip:
    Next oLayout
End Sub

Public Sub VPzXP2()
  Dim oLayout As AcadLayout
  Dim oLayouts As AcadLayouts
  Dim B As AcadBlock
  Dim Ent As AcadEntity
  Dim vp As AcadPViewport
  Dim N As Double
      
  Set oLayouts = ThisDrawing.Layouts
    For Each oLayout In oLayouts
        If UCase(oLayout.Name)  "MODEL" Then
          Set B = oLayout.Block
            For Each Ent In B
                If TypeOf Ent Is AcadPViewport Then
                  If Ent.ObjectID  B(0).ObjectID Then
                    Set vp = Ent
                    If vp.DisplayLocked = True Then
                          vp.DisplayLocked = False
                    End If
                    ThisDrawing.ActiveLayout = oLayout
                    vp.Display True
                    ThisDrawing.MSpace = True
                    ZoomExtents
                    N = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
                    N = 1 / N
                    ZoomScaled N, 2
                    ThisDrawing.MSpace = False
                    vp.DisplayLocked = True
                  End If
                End If
            Next Ent
        End If
  Next oLayout
End Sub