请教版主关于多个视口同时缩放的问题~

daneal

    大家好，小弟最近在做一个程序，需要用到4个视口，然后在4个视口中同时缩放显示图形，但是发现只能缩放最后一个视口，之前的缩放都会无效，不知道高手有没有什么好方法？急求~谢谢了

daneal

悲剧的没有人回答，自己琢磨了一下做出了，写下来给大家一些灵感~

daneal

我是打算用4个模型视口，分别显示显示零件的4个不同的方向，并且自动缩放至合适尺寸，因为四个视口无法直接使用zoomextens缩放，只能缩放后再保存当前的视图位置，并且要转至相应的UCS才能够正常缩放，代码如下：
Function changeto3d()
Dim vport As AcadViewport
Dim viewpt(0 To 2) As Double
Dim vSize As Double
Dim sSize As Variant
Dim vCenter As Variant
Dim portcenter As Variant
Dim currucs As AcadUCS
builducs   '用函数建立topucs,frontucs,leftucs,3ducs 这四不同的ucs，分别代表前视，俯视、左视与轴侧图
'保存当前ucs
    If ThisDrawing.GetVariable("UCSNAME") = "" Then
        ' Current UCS is not saved so get the data and save it
        With ThisDrawing
            Set currucs = .UserCoordinateSystems.Add( _
                            .GetVariable("UCSORG"), _
                            .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
                            .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
                            "OriginalUCS")
        End With
    Else
        Set currucs = ThisDrawing.activeucs  'current UCS is saved
    End If
'删除之前的分割视口
If ThisDrawing.Viewports.count > 1 Then
  ThisDrawing.Viewports.DeleteConfiguration ("四视图")
End If
ThisDrawing.Regen acAllViewports
'将视口分为4个
Set vport = ThisDrawing.Viewports.Add("四视图")
vport.Split acViewport4

For Each vport In ThisDrawing.Viewports
On Error Resume Next
If vport.Name = "四视图" Then    '定义每个视口的视图方向
If vport.LowerLeftCorner(0) = 0 And vport.LowerLeftCorner(1) = 0 Then
     viewpt(0) = 0
     viewpt(1) = 0
     viewpt(2) = 1
     ThisDrawing.activeucs = topUCS
  End If
  If vport.LowerLeftCorner(0) = 0 And vport.LowerLeftCorner(1) = 0.5 Then
     viewpt(0) = 0
     viewpt(1) = -1
     viewpt(2) = 0
     ThisDrawing.activeucs = frontUCS
  End If
  If vport.LowerLeftCorner(0) = 0.5 And vport.LowerLeftCorner(1) = 0.5 Then
     viewpt(0) = -1
     viewpt(1) = 0
     viewpt(2) = 0
     ThisDrawing.activeucs = leftUCS
  End If
  If vport.LowerLeftCorner(0) = 0.5 And vport.LowerLeftCorner(1) = 0 Then
     viewpt(0) = -1
     viewpt(1) = -1
     viewpt(2) = Sqr(2)
     ThisDrawing.activeucs = 3DUCS
  End If
'将视图方向转化并激活
  vport.Direction = viewpt
  vport.SnapRotationAngle = 0
  ThisDrawing.ActiveViewport = vport

'保存缩放后的视图方向
  ZoomExtents
  vSize = ThisDrawing.GetVariable("VIEWSIZE")'取得屏幕高度
  sSize = ThisDrawing.GetVariable("SCREENSIZE")'取得屏幕分辨率比例
  vCenter = ThisDrawing.GetVariable("VIEWCTR")'取得中心点位置
  vport.Height = vSize
  vport.Width = sSize(0) / sSize(1) * vSize
  portcenter = vport.center
  portcenter(0) = vCenter(0): portcenter(1) = vCenter(1)
  vport.center = portcenter
  ThisDrawing.ActiveViewport = vport'修改视图参数并激活
End If
Next vport
'恢复ucs
    ThisDrawing.activeucs = currucs
End Function

符颢1990

木頭集