[原创]：非常实用的“自动PAN”

lijiao · 发表于 2003-5-12 11:23:19

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

适合画大图的朋友

[FONT=courier new]
Public WithEvents InputMgr As AcadXInputManager
Public Sub AcadStartup()
If InputMgr Is Nothing Then
Set InputMgr = New AcadXInputManager
End If
InputMgr.InputPointEventsEnabled = True
End Sub
Private Sub InputMgr_InputPointEvent(Document As AutoCAD.AcadDocument, RawPoint As Variant, ComputedPoint As Variant, ByVal History As Long)
Dim Vctr As Variant
Dim Vbl As Variant
Dim Vsize As Double
Dim Vchang As Double
Dim Mypro As String
Dim RawPoint1 As Variant
RawPoint1 = ThisDrawing.Utility.TranslateCoordinates(RawPoint, acWorld, acDisplayDCS, False)
Vctr = ThisDrawing.Utility.TranslateCoordinates(ThisDrawing.GetVariable("viewctr"), acUCS, acDisplayDCS, False)
Vsize = ThisDrawing.GetVariable("viewsize")
Vbl = ThisDrawing.GetVariable("screensize")
Vchang = Vbl(0) * Vsize / Vbl(1)
Vsize = Vsize * 0.4
Vchang = Vchang * 0.4
If Abs(RawPoint1(0) - Vctr(0)) > Vchang Or Abs(RawPoint1(1) - Vctr(1)) > Vsize Then
ThisDrawing.Application.ZoomCenter Mypoint(ThisDrawing.Utility.TranslateCoordinates(Vctr, acDisplayDCS, acWorld, False), RawPoint), ThisDrawing.GetVariable("viewsize")
End If
End Sub
Private Function Mypoint(pt1 As Variant, pt2 As Variant) As Variant
Dim Pt(2) As Double
Dim bl As Double
bl = 0.03
Pt(0) = pt1(0) + (pt2(0) - pt1(0)) * bl
Pt(1) = pt1(1) + (pt2(1) - pt1(1)) * bl
Pt(2) = pt1(2) + (pt2(2) - pt1(2)) * bl
Mypoint = Pt
End Function
[/FONT]

[FONT=courier new] 
Public WithEvents InputMgr As AcadXInputManager 
 
 
Public Sub AcadStartup() 
    If InputMgr Is Nothing Then 
        Set InputMgr = New AcadXInputManager 
    End If 
    InputMgr.InputPointEventsEnabled = True 
 
End Sub 
 
 
Private Sub InputMgr_InputPointEvent(Document As AutoCAD.AcadDocument, RawPoint As Variant, ComputedPoint As Variant, ByVal History As Long) 
 
    Dim Vctr As Variant 
    Dim Vbl As Variant 
    Dim Vsize As Double 
    Dim Vchang As Double 
    Dim Mypro As String 
    Dim RawPoint1 As Variant 
    RawPoint1 = ThisDrawing.Utility.TranslateCoordinates(RawPoint, acWorld, acDisplayDCS, False) 
    Vctr = ThisDrawing.Utility.TranslateCoordinates(ThisDrawing.GetVariable("viewctr"), acUCS, acDisplayDCS, False) 
    Vsize = ThisDrawing.GetVariable("viewsize") 
    Vbl = ThisDrawing.GetVariable("screensize") 
    Vchang = Vbl(0) * Vsize / Vbl(1) 
    Vsize = Vsize * 0.4 
    Vchang = Vchang * 0.4 
    
    If Abs(RawPoint1(0) - Vctr(0)) > Vchang Or Abs(RawPoint1(1) - Vctr(1)) > Vsize Then 
       ThisDrawing.Application.ZoomCenter Mypoint(ThisDrawing.Utility.TranslateCoordinates(Vctr, acDisplayDCS, acWorld, False), RawPoint), ThisDrawing.GetVariable("viewsize") 
       
    End If 
 
End Sub 
 
 
Private Function Mypoint(pt1 As Variant, pt2 As Variant) As Variant 
   Dim Pt(2) As Double 
   Dim bl As Double 
   bl = 0.03 
   Pt(0) = pt1(0) + (pt2(0) - pt1(0)) * bl 
   Pt(1) = pt1(1) + (pt2(1) - pt1(1)) * bl 
   Pt(2) = pt1(2) + (pt2(2) - pt1(2)) * bl 
   Mypoint = Pt 
End Function 
  [/FONT]

************************************************************************************
由于我一时大意，忘记了UCS的影响，现在已经修改重新上传，希望大家重新下载。

lijiao · 发表于 2003-5-12 11:25:39

运行DVB中的STARTUP宏即可。（自动运行效果更好）
效果：当你需要观察屏幕外边的图形时，只要你把鼠标移动到屏幕边缘，屏幕外边的图形就会慢慢进来。
************************************************************************************
由于我一时大意，忘记了UCS的影响，现在已经修改重新上传，希望大家重新下载。

lijiao · 发表于 2003-5-13 10:40:32

运行效果

LUCAS · 发表于 2003-5-15 12:33:18

;;acadx.arx原来有人用??
;;我也贴一个改autocad标题程序
(arxload "acadx.arx" NIL)
(vl-load-com)
(defun C:XDE (/ XDB APP)
(setq APP (vlax-get-acad-object))
(setq XDE (vla-getinterfaceobject APP "AcadX.Drawingeditor"))
(vlax-put-property
XDE
'CAPTION
"龙龙仔";;标题
)
(vlax-release-object APP)
(arxunload "acadx.arx")
(princ)
)
(c:xde)
(princ)

艾飞 · 发表于 2003-5-18 08:20:02

哈哈..不错
我也下载试试..
有没有自动生成图纸副面的程序吗..要免费的..

zshutang · 发表于 2003-5-18 10:28:10

用LISP编一个。　

风中骷髅 · 发表于 2003-5-19 16:38:16

"运行DVB中的STARTUP宏即可。（自动运行效果更好）"
不明白
用appload不行吗？

efan2000 · 发表于 2003-5-19 20:26:19

当然也可以，在加载应用程序的对话框中，将其放入到启动组，以后ACAD启动时，也将自动加载程序。

eachy · 发表于 2003-5-19 20:36:15

[QUOTE]最初由 LUCAS 发布
[B]

;;acadx.arx原来有人用??
;;我也贴一个改autocad标题程序
(arxload "acadx.arx" NIL)
(vl-load-com)
(defun C:XDE (/ XDB APP)
(setq APP (vlax-get-acad-object))
(setq XDE (vla-getinterfaceob... [/B][/QUOTE]
不错的东西，也要学习学习。
[CODE]
<table border="1" cellpadding="0" cellspacing="0" style="border-collapse: collapse" bordercolor="#111111" width="700" id="AutoNumber1" height="498">
<tr>
<td width="100%" height="489">
<iframe name="I1" width="100%" height="100%" src="http://members.bellatlantic.net/~vze2vjds/acadx/acadx.htm">
浏览器不支持嵌入式框架或配置为不显示嵌入式框架
</iframe>
</td>
</tr>
</table>

9071 · 发表于 2003-5-19 20:36:37

谢,好用

lko · 发表于 2003-5-26 23:33:49

我照你说的做了，显示加载成功，但不知怎么用不起，你能再说详细一点吗？谢谢。

lijiao · 发表于 2003-5-27 08:55:36

最初由 lko 发布
[B]我照你说的做了，显示加载成功，但不知怎么用不起，你能再说详细一点吗？谢谢。 [/B]

不用发任何命令，只要两个条件成立即可自动起作用。
条件一：能够输入点。
条件二：鼠标在绘图区边缘移动。

风中骷髅 · 发表于 2003-5-27 23:14:38

结合起来理解：
是指我将要输入点时
line或者pline或者spline然后将鼠标在绘图区边缘移动？

lijiao · 发表于 2003-5-28 08:53:08

最初由风中骷髅发布
[B]结合起来理解：
是指我将要输入点时
line或者pline或者spline然后将鼠标在绘图区边缘移动？ [/B]

输入点的时候很多，如没有运行命令时、输入距离时、选择实体时等等等等。

pandoit · 发表于 2003-5-28 09:14:13

太高级了，我也不会用，如何加载请那位详细说一下，我用ap加了，但是不起作用

账号		自动登录	找回密码
密码			立即注册

[原创]：非常实用的“自动PAN”

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子