请教版主关于多个视口同时缩放的问题~
大家好，小弟最近在做一个程序，需要用到4个视口，然后在4个视口中同时缩放显示图形，但是发现只能缩放最后一个视口，之前的缩放都会无效，不知道高手有没有什么好方法？急求~谢谢了悲剧的没有人回答，自己琢磨了一下做出了，写下来给大家一些灵感~ 我是打算用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
页:
[1]