马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。
您需要 登录 才可以下载或查看,没有账号?立即注册
×
这是自己编写的一个程序,功能如题。
但自觉这个程序还是很有问题,主要是由于每个视口在平移时都要重生成一次,如果图形较大运行就很慢。
所以在此仅作抛砖引玉,请各位高人多多指点。![](source/plugin/imc_colorcode/images/loading.gif)
- [FONT=courier new]
- 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
- [/FONT]
|