[LISP程序]：动态缩放屏幕

rtyytr

(defun c:crtvv ( / biaoji pt ucsicon osmode mypan myzoomd myzoomx mymove)

(defun MYPAN (Ppt1 ppt0 / pn pang pdis)
  (setq pn 10)
  (setq pang (angle ppt1 ppt0))
  (setq pdis (/ (distance ppt1 ppt0) 10))

  (repeat pn
    (command "pan" ppt1 ppt0)
    )
  )
(defun MYzoomd (zc / zn zx zc zh zpt1 zpt2)
  (setq zn 20)
  (setq zx 0.05)
  (repeat zn
    (setq zh (/ (getvar "viewsize") 2))

    (setq zpt2 (list (+ (car zc) (* zx zh)) (- (+ (cadr zc) zh) (* zx zh))))
    (command "zoom" zpt1 zpt2)
    )
  )
(defun MYzoomx (zc / zn zx zc zh zpt1 zpt2)
  (setq zn 20)
  (setq zx 0.05)
  (repeat zn
    (setq zh (/ (getvar "viewsize") 2))
    (setq zpt1 (list (- (car zc) (* zx zh)) (- (- (cadr zc) zh) (* zx zh))))

    (command "zoom" zpt1 zpt2)
    )
  )
(defun Mymove (mpt / mxx mh mx mc)
  (setq mxx 0.1)
  (setq mh (/ (getvar "viewsize") 2))
  (setq mx (getvar "screensize"))
  (setq mx (* (/ (car mx) (cadr mx)) mh))
  (setq mxx (* mxx mh))
  (setq mh (- mh mxx)
        mx (- mx mxx))
  (setq mc (getvar "viewctr"))
  (if (or (> (car mpt) (+ (car mc) mx))
          (< (car mpt) (- (car mc) mx))

          (< (cadr mpt) (- (cadr mc) mh))
          )
    (mypan mpt (polar mpt (angle mpt mc) (/ mh 10)))
    )
  )
  
  (setvar "cmdecho" 0)
  (setq ucsicon (getvar "ucsicon"))
  (setq osmode (getvar "osmode"))
  (setvar "osmode" 0)
  (setvar "ucsicon" 0)
  (command "ucs" "view")
  (princ "\n左击放大／右击缩小／屏幕边缘为平移／CTRL（或SHIFT）+右击或空格或回车退出：")
  (setq biaoji t)
  (while biaoji
    (setq PT (grread t 4 0))
    (cond
      ((= 3 (car pt))
       (myzoomd (cadr pt))
       )
      ((= 2 (car pt))
       (cond
         ((or (= 32 (cadr pt))
              (= 13 (cadr pt))
              )
          (setq biaoji nil)
          )
         (t (princ))
         )
       )
      ((= 5 (car pt))
       (mymove (cadr pt))
       )
      ((= 11 (car pt))
       (setq biaoji nil)
       )
      ((= 25 (car pt))
       (setq PT (grread t 4 0))
       (myzoomx (cadr pt))
       )
      (t (princ))
      )
    )
  (command "ucs" "p")
  (setvar "osmode" osmode)
  (setvar "ucsicon" ucsicon)
  (setvar "cmdecho" 1)
  (princ)
  )