[LISP程序]：自动平移视图的程序

urljit · 发表于 2005-1-30 11:13:55

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

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

×

看看有用否？[PHP](defun c:nn ( / DRAWING_WIDTH N PTLD PTLM PTRU VCTR VSZ PANDIST)
 (setq ptld (getvar "extmin")
ptru (getvar "extmax")
n 0
 )
 (setq vctr (getvar "viewctr")
vsz (getvar "viewsize")
 )
 (setq drawing_width
 (distance (setq ptlm (list (car ptld) (cadr ptru)))
 ptru
 )
 )
 (setq ptlm(polar ptlm (* -0.5 pi)(* 0.5 vsz)))
 (setq pandist(getdist "\n请输入pan距离<1/40屏幕>:"))
 (terpri)
 (if (null pandist)(setq pandist(/ vsz 40)))
 (command "pan" ptlm vctr)
 (while (> drawing_width
 (distance (setq vctr (getvar "viewctr")) ptlm)
 )
(command "pan" (polar vctr 0 pandist) vctr)
(princ "\r")
(princ (setq n(1+ n)))
 )
 (princ "\r程序结束。By:URLJIT.")
 (princ)
)[/PHP]

xyp1964 · 发表于 2005-1-30 11:45:33

看不出有啥子用！(princ (setq n(1+ n))) 要显示“半天”。
3D滚轮应该很好用了！

urljit · 发表于 2005-1-30 11:53:01

这个程序可以让你边喝茶边看图，它还是动的！

xyp1964 · 发表于 2005-1-30 13:05:04

当做动画欣赏也许还成！

hi71400 · 发表于 2005-1-30 21:19:34

有点意思。可惜没有实用价值。建议1，允许手工框选浏览范围。2，变平滑移动为快速平移＋定格。而定格的时间间隙应该可调。3，可以不停循环，按键后随时中止。或暂停。暂停期间可以人工缩放。

啵浪鼓 · 发表于 2005-1-30 23:35:25

是啊,程序缺少人为意图,少了点创意

wengsg · 发表于 2005-1-31 08:41:55

转载：画线过程中实现自动移屏，但线条不能连成一条线。
(defun c:pp ()
 (setvar "cmdecho" 0)
 (vl-load-com)
 (if (setq point (getpoint "\n请选择起点"))
(progn
 (setq draw t
 ss (ssadd)
 pts nil
 pts (cons point pts)
 modespace (vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
 )
 )
 (while draw
(initget 128 "U E C_u e c")
(setq point
 (getpoint (car pts) "\n 返回U/闭合Cl/<Endpoint to line>:")
)
(cond
 ((or (= point nil) (= point "e") (= point "c"))
 (command "pline" (car pts) (car pts) "")
 (setq ss (ssadd (entlast) ss))
 (setq draw nil)
 )
 ((= point "u")
 (if (= (length pts) 1)
 (print "can't undo.")
 (progn
 (setq pts (cdr pts))
 (command "zoom" "c" (car pts) "100")
 (command "erase" (entlast) "")
 )
 )
 )
 ((= (type point) 'list)
 (command "zoom" "c" point "16")
 (command "pline" (car pts) point "")
 (setq pts (cons point pts))
 (setq ss (ssadd (entlast) ss))
 )
)
 )
 (if (> (length pts) 1)
(progn
 (setq ven (vla-addPolyline
 modespace
 (apply 'append (reverse pts))
 )
 )
 (if (= point "c")
 (vla-put-Closed ven t)
 )
 (vlax-release-object ven)
)
 )
 (command "erase" ss "")
)
 )
 (prin1)
)

hi71400 · 发表于 2005-2-2 09:14:46

两位长老:
我建议把这个"览图"做成具有实际用途的东西,真正实现边喝茶边看图
愚兄先提几个思路:
1,浏览范围,可以指定,缺省为,整个绘图区域的极限.
2,将范围画分为n*m个浏览区
3,浏览区相当于视图停留的"视窗"
4,区格的大小,以包含在区隔中的图元的文字大小确定
5浏览时自动跳过"空区"
6,延时问题,以循环,不断读取系统时间就可搞定
7每个视区的切换,可以使用上面1楼的"动画演示"嘻嘻
8,增加人工干预,甚至页面翻动.哈
看两位长老的啦,我等着喔
如果需要愚兄解决什么问题,写个什么小东东尽管吩咐好了.
我希望这是大家合作攻关的先例
长老们意下如何?

urljit · 发表于 2005-2-2 11:48:46

楼上老兄：你过谦了，你的建议很好，等春节放假了，可以考虑合作开发这个题目，不知道xyp意下如何？

xyp1964 · 发表于 2005-2-2 13:18:49

乐意合作，听候吩咐！呵呵……

hi71400 · 发表于 2005-2-3 14:19:12

XYP兄:
你积分这么高,一定是常做善事啦,你来主持如何?
我与urljit已经联系上了.春节放假弄个东东出来
既然我们在这里已经公开说了此事,
可别自砸招牌呀---有不少新手看着咱们呢
哈哈.
我已经试做了一个"在PKPM梁图中立即显示指定梁"的小玩意.
确实很方便
其中,我采用的是zoom中的"c",感觉比pan方便,倍数大小取文字高度的35倍比较合适
.在(800x600)上
献丑了
(defun c:555PKl (/ ss_pm n1 obj1 what txt_h p1 p2 p22 p3 p32 cmds c_lay ss
 l bj)
 (setq c_lay (getvar "clayer"))
 (setvar "osmode" 0)
 (setq ss_pm (ssget "x"
 '((-4 . "<AND")
 (0 . "TEXT")
 (-4 . "<OR")
 (8 . "水平标注")
 (8 . "垂直标注")
 (-4 . "OR>")
 (-4 . "AND>")
 )
 )
 )
 (tw_w_stlay "err_tmp_find" 1 "Continuous")
 (setq ss (ssget "x" '((8 . "err_tmp_find"))))
 (if ss
(command "erase" ss "")
 )
 (setq bj 0)
 (setq what (getstring "\n有请哪条梁出来:"))
 (setq what1 (strcat what "(*"))
;(princ "\n不骂还真不出来！ ")
 (setq n1 (sslength ss_pm))
 (while (> n1 0)
(setq obj1 (ssname ss_pm (1- n1))
 n1 (1- n1)
)
(setq nam1 (zrh_tq 1 obj1))
;(if (= (strcase nam1) (strcase what)) WCMATCH
(if (WCMATCH (strcase nam1) (strcase what1))
 (progn
(setq txt_h (zrh_tq 40 obj1)
 l (* txt_h 4.0)
 w (* txt_h 0.3)
)
(setq p1 (zrh_tq 10 obj1)
 bj (1+ bj)
)
(setq
 p2 (list (+ (car p1) l) (+ (cadr p1) l) (caddr p1))
 p22 (list (- (car p1) l) (- (cadr p1) l) (caddr p1))
 p3 (list (- (car p1) l) (+ (cadr p1) l) (caddr p1))
 p32 (list (+ (car p1) l) (- (cadr p1) l) (caddr p1))
)
(command "Pline" p2 "w" w w p22 "")
(command "Pline" p3 "w" w w p32 "")
(setq l (* txt_h 80))
(setq
 p2 (list (+ (car p1) l) (+ (cadr p1) l) (caddr p1))
 p22 (list (- (car p1) l) (- (cadr p1) l) (caddr p1))
 p3 (list (- (car p1) l) (+ (cadr p1) l) (caddr p1))
 p32 (list (+ (car p1) l) (- (cadr p1) l) (caddr p1))
)
(command "line" p2 p22 "")
(command "line" p3 p32 "")
(setq cmds (strcat (rtos (+ (car p1) 1200.0))
 ","
 (rtos (- (cadr p1) 300))
 )
)
(setq h (itoa (fix (* 35 txt_h))))
(if (= bj 1)
 (command "_zoom" "c" cmds h)
)
 )
)
 )
 (setvar "clayer" c_lay)
 (if (= bj 0)
(princ "\n没搞错?! 扯淡! 没有!!")
 )
 (if (> bj 1)
(princ (strcat "\n哈!!共有 " (itoa bj) "个呢"))
 )
 (setvar "osmode" 167)
 (princ)
)
其中有两个函数这里没有sgeich定义,你应该能猜到的喔,哈哈

urljit · 发表于 2005-2-3 18:15:58

同意hi的意见，希望xyp能主持。今天上午抽时间考虑了一下子，结果没有时间作，因为下午在麦田里面转了一下午（要施工了），就在这里简单说说吧。

如果要考虑暂停，我不知道采用什么函数才能取得键盘的信息（关键是不按的时候要继续运行），所以就考虑到用grread，用鼠标来得到暂停信息，不知是否可行？

先作大框架。

Free-Lancer · 发表于 2005-2-3 20:19:58

随便写了个, 不知理解的对不对----only for Cad2005

;;example -- object zoom
(defun c:tt (/ ss tf oerr merr)
(defun merr (msg)
(if (/= msg "Cancel")
(princ "\n*Canceled*")
)
(if (tblsearch "view" "$my_tmp")
(vl-cmdf ".view" "d" "$my_tmp")
)
(setq *error* olderr)
(princ)
)
(setq tf t
oerr *error*
*error* merr
)
(while tf
(if (tblsearch "view" "$my_tmp")
(vl-cmdf ".view" "r" "$my_tmp")
)
(princ "\nSelect Object to Zoom Extend ...")
(if (setq ss (ssget))
(progn
(if (not (tblsearch "view" "$my_tmp"))
(vl-cmdf ".view" "s" "$my_tmp")
)
(vl-cmdf ".zoom" "o" ss "")
(princ "\n[ R ] to Return, Any Key Exit..")
(setq str (grread))
(if (not (equal str '(2 114)))
(setq tf nil)
)
)
(setq tf nil)
)
)
(if (tblsearch "view" "$my_tmp")
(progn
(vl-cmdf ".view" "r" "$my_tmp")
(vl-cmdf ".view" "d" "$my_tmp")
)
)
(setq *error* nil
merr nil
)
(princ)
)

;;example -- object zoom 
(defun c:tt (/ ss tf oerr merr) 
  (defun merr (msg) 
    (if        (/= msg "Cancel") 
      (princ "\n*Canceled*") 
    ) 
    (if        (tblsearch "view" "$my_tmp") 
      (vl-cmdf ".view" "d" "$my_tmp") 
    ) 
    (setq *error* olderr) 
    (princ) 
  ) 
  (setq        tf t 
        oerr *error* 
        *error*        merr 
  ) 
  (while tf 
    (if        (tblsearch "view" "$my_tmp") 
      (vl-cmdf ".view" "r" "$my_tmp") 
    ) 
    (princ "\nSelect Object to Zoom Extend ...") 
    (if        (setq ss (ssget)) 
      (progn 
        (if (not (tblsearch "view" "$my_tmp")) 
          (vl-cmdf ".view" "s" "$my_tmp") 
        ) 
        (vl-cmdf ".zoom" "o" ss "") 
        (princ "\n[ R ] to Return, Any Key Exit..") 
        (setq str (grread)) 
        (if (not (equal str '(2 114))) 
          (setq tf nil) 
        ) 
      ) 
      (setq tf nil) 
    ) 
  ) 
  (if (tblsearch "view" "$my_tmp") 
    (progn 
      (vl-cmdf ".view" "r" "$my_tmp") 
      (vl-cmdf ".view" "d" "$my_tmp") 
    ) 
  ) 
  (setq        *error*        nil 
        merr nil 
  ) 
  (princ) 
)

urljit · 发表于 2005-2-3 20:56:10

不好意思，没有2005，不能测试。

不过，好像用不到ssget

xyp1964 · 发表于 2005-2-3 21:44:32

最初由 hi71400 发布
[B]XYP兄:
你积分这么高,一定是常做善事啦,你来主持如何?
我与urljit已经联系上了.春节放假弄个东东出来
既然我们在这里已经公开说了此事,
可别自砸招牌呀---有不少新手看着咱们呢
哈哈.
我已经试做了一个"在PKPM... [/B]

未定义函数“tw_w_stlay”。
ssget函数的“or、and”模式：
(setq ss_pm (ssget '((0 . "TEXT") (8 . "水平标注,垂直标注"))))

先提供一个简单的：
[php]
;;;自动平移视图
(defun c:test ()
 (cmdla0)
 (command "zoom" "e")
 (setq no1 (uint 1 "" "\n每幅持续秒数" no1)
no2 (uint 1 "" "\n步幅" no2)
 )
 (setq h (getvar "VIEWSIZE")
vpt (getvar "VIEWCTR")
dy (/ h 3.0)
dx (* dy 2.1)
pt00 (list (- (car vpt) (* dx 1.5)) (- (cadr vpt) (* dy 1.5)))
;pt33 (list (+ (car vpt) (* dx 1.5)) (+ (cadr vpt) (* dy 1.5)))

;pt01 (list (+ (car pt00) dx) (cadr pt00))
;pt02 (list (+ (car pt01) dx) (cadr pt00))

pt10 (list (car pt00) (+ (cadr pt00) dy))
pt11 (list (+ (car pt10) dx) (cadr pt10))
;pt12 (list (+ (car pt11) dx) (cadr pt10))
;pt13 (list (+ (car pt12) dx) (cadr pt10))

pt20 (list (car pt10) (+ (cadr pt10) dy))
pt21 (list (+ (car pt20) dx) (cadr pt20))
;pt22 (list (+ (car pt21) dx) (cadr pt20))
;pt23 (list (+ (car pt22) dx) (cadr pt20))

pt30 (list (car pt20) (+ (cadr pt20) dy))
pt31 (list (+ (car pt30) dx) (cadr pt30))
;pt32 (list (+ (car pt31) dx) (cadr pt30))
 )
 ;;(command"pline" pt00 pt01 pt02 pt10 pt11 pt12 pt13 pt20 pt21 pt22 pt23 pt30 pt31 pt32 pt33 "")
 (while t
(command "zoom" pt00 pt11)
(pp no1 no2)
(command "zoom" pt10 pt21)
(pp no1 no2)
(command "zoom" pt20 pt31)
(pp no1 no2)
 )
 (cmdla0)
)
(defun pp (time no)
 (setq nt 0
dt (/ time no 1.0)
 )
 (while (< nt time)
(command "delay" (fix(/ (* time 1000) no)))
(command "-pan"
 (getvar "VIEWCTR")
 (polar (getvar "VIEWCTR") pi (/ (* dx 3) no))
)
(setq nt (+ nt dt))
 )
)
(defun uint (bit kwd msg def / inp)
 (if def
(setq msg (strcat "\n" msg "<" (itoa def) ">: ")
 bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
 )
 (initget bit kwd)
 (setq inp (getint msg))
 (if inp inp def)
)
(defun CMDLA0 ()
 (setq cmdech (getvar "CMDECHO")
oom (getvar "orthomode")
osm (getvar "osmode")
LA (getvar "clayer")
rmode (getvar "regenmode")
pw (getvar "plinewid")
 )
 (command "ucs" "")
 (setvar "plinewid" 0)
 (setvar "regenmode" 0)
 (setvar "CMDECHO" 0)
 (princ)
)
(defun CMDLA1 ()
 (setvar "CMDECHO" cmdech)
 (setvar "orthomode" oom)
 (setvar "osmode" osm)
 (setvar "clayer" LA)
 (setvar "regenmode" rmode)
 (setvar "plinewid" pw)
 (princ)
)[/php]

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

[LISP程序]：自动平移视图的程序

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

相关帖子