缩放视口

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