akang 发表于 2005-1-5 14:29:47

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

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

Option Explicit
Sub vppan()
   

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





清风明月10 发表于 2014-3-25 14:34:00

谢谢楼主！又学一招。

st788796 发表于 2014-3-25 16:06:49

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

nijiea123 发表于 2021-12-6 10:30:57

不错不错 来学习一下

xvjiex 发表于 2022-3-20 10:41:30

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

qwangjun1994 发表于 2022-9-2 17:59:35

好东西，一直想要
页: [1]
查看完整版本: [讨论]：模型空间中多个视口同时平移视图的程序