[讨论]：模型空间中多个视口同时平移视图的程序

akang

这是自己编写的一个程序，功能如题。
但自觉这个程序还是很有问题，主要是由于每个视口在平移时都要重生成一次，如果图形较大运行就很慢。
所以在此仅作抛砖引玉，请各位高人多多指点。

2. 
   
3.   [FONT=courier new]
   
4. Option Explicit
   
5. Sub vppan()
   
6.    
   
7. 
   
8.    
   
9.     Dim vport As AcadViewport
   
10.     Dim vport1 As AcadViewport
    
11.     Dim pt1 As Variant
    
12.     Dim pt2 As Variant
    
13.     Dim pt_center As Variant
    
14.     pt1 = ThisDrawing.Utility.GetPoint(, "请选择第一点:")
    
15.     pt2 = ThisDrawing.Utility.GetPoint(ThisDrawing.Utility.TranslateCoordinates _
    
16.         (pt1, acWorld, acUCS, False), "请选择下一点:")
    
17.     pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acUCS, False)
    
18.     pt2 = ThisDrawing.Utility.TranslateCoordinates(pt2, acWorld, acUCS, False)
    
19.    
    
20.    
    
21.       
    
22.         On Error Resume Next
    
23.         ThisDrawing.SendCommand "-vports" & vbCr & "s" & vbCr & _
    
24.             "akang_vport" & vbCr & "y" & vbCr
    
25.         Set vport1 = ThisDrawing.ActiveViewport
    
26.         'n = 1
    
27.         For Each vport In ThisDrawing.Viewports
    
28.             If vport.Name = "akang_vport" Then
    
29.                 ThisDrawing.ActiveViewport = vport
    
30.                 pt_center = vport.Center
    
31.                 pt_center(0) = pt_center(0) - pt2(0) + pt1(0) '* (width1 / width2)
    
32.                 pt_center(1) = pt_center(1) - pt2(1) + pt1(1) '* (width1 / width2)
    
33.                 vport.Center = pt_center
    
34.             End If
    
35.         Next vport
    
36.         ThisDrawing.ActiveViewport = vport1
    
37. End Sub
    
38. 
    
39. 
    
40. 
    
41. 
    
42.   [/FONT]
    

<br />   [FONT=courier new]<br /> Option Explicit<br /> Sub vppan()<br />    <br /> <br />    <br />     Dim vport As AcadViewport<br />     Dim vport1 As AcadViewport<br />     Dim pt1 As Variant<br />     Dim pt2 As Variant<br />     Dim pt_center As Variant<br />     pt1 = ThisDrawing.Utility.GetPoint(, "请选择第一点:")<br />     pt2 = ThisDrawing.Utility.GetPoint(ThisDrawing.Utility.TranslateCoordinates _<br />         (pt1, acWorld, acUCS, False), "请选择下一点:")<br />     pt1 = ThisDrawing.Utility.TranslateCoordinates(pt1, acWorld, acUCS, False)<br />     pt2 = ThisDrawing.Utility.TranslateCoordinates(pt2, acWorld, acUCS, False)<br />     <br />     <br />       <br />         On Error Resume Next<br />         ThisDrawing.SendCommand "-vports" & vbCr & "s" & vbCr & _<br />             "akang_vport" & vbCr & "y" & vbCr<br />         Set vport1 = ThisDrawing.ActiveViewport<br />         'n = 1<br />         For Each vport In ThisDrawing.Viewports<br />             If vport.Name = "akang_vport" Then<br />                 ThisDrawing.ActiveViewport = vport<br />                 pt_center = vport.Center<br />                 pt_center(0) = pt_center(0) - pt2(0) + pt1(0) '* (width1 / width2)<br />                 pt_center(1) = pt_center(1) - pt2(1) + pt1(1) '* (width1 / width2)<br />                 vport.Center = pt_center<br />             End If<br />         Next vport<br />         ThisDrawing.ActiveViewport = vport1<br /> End Sub<br /> <br /> <br /> <br /> <br />   [/FONT]<br />

清风明月10

谢谢楼主！又学一招。

st788796

运行前关闭重生成，最后打开

nijiea123

不错不错 来学习一下

xvjiex

感谢楼主分享！回复看看。

qwangjun1994

好东西，一直想要