【KAIXIN】 发表于 2011-12-10 19:47:11

动态对象跟着鼠标走




;本程序选择一个对象,让其跟着鼠标走
(defun c:KK (/txten wexit gr gr1 p)
(setq txten (assoc -1 (entget (car (entsel)))))
(setq wexit nil)
(while (not wexit)
    (setq gr(grread t)
      gr1 (car gr)
    )
    (cond ((= gr1 5)
       (progn
         (setq p (cadr gr))
         (setq p (grreadosnap p))    ;
         (entmod (list txten (cons 10 p)))
       )
      )
      ((equal gr '(2 6))      ;F3可设置捕捉值
       (command "_+dsettings" 2)
      )
      (t (setq wexit t))
    )
)
(princ)
)

;以下程序是围绕pt点画一个框
(defun grbox (pt / h p1 p2 p3 p4)
;;copy from eachy
(setq    h(* (/ (getvar "viewsize") (cadr (getvar "screensize")))
          (getvar "pickbox")
       )
    p1 (mapcar '- pt (list h h 0.))
    p2 (mapcar '+ pt (list h (- h) 0.))
    p3 (mapcar '+ pt (list h h 0.))
    p4 (mapcar '+ pt (list (- h) h 0.))
)
(grvecs (list 1 p1 p2 1 p2 p3 1 p3 p4 1 p4 p1))
)
;什么捕捉也没有时,启用所有捕捉功能
(defun grreadosnap (p / osp osmode str x)
;;grreadosnap ---fsxm 2006.10.06
(setq osmode (getvar "osmode"))
(cond    ((= osmode 0))
    ((< osmode 16000)
   (setq str "")
   (foreach x '((1 "_end,")
            (2 "_mid,")
            (4 "_cen,")
            (8 "_nod,")
            (16 "_qua,")
            (32 "_int,")
            (64 "_ins,")
            (128 "_per,")
            (256 "_tan,")
            (512 "_nea,")
            (2048 "_app,")
            (4096 "_ext,")
            (8192 "_par,")
             )
       (if (/= 0 (logand osmode (car x)))
         (setq str (strcat str (cadr x)))
       )
   )
   (setq osp (osnap p str))
   (redraw)
   (cond (osp
      (setq p osp)
      (grbox osp)
         )
   )
    )
)
p
)



http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 【KAIXIN】的微博

cabinsummer 发表于 2011-12-10 21:40:11

你最近特喜欢grread啊？

【KAIXIN】 发表于 2011-12-10 22:43:45

不是，好奇这个，这个还是比较慢

我喜欢通用函数【扩展函数】

飞诗(fsxm) 发表于 2011-12-10 23:00:00

试下高飞鸟那个动态的，不是这个命令一结束就game over
你做别的事时它也能一直跟着~

cbsz 发表于 2012-1-4 19:16:31

本帖最后由 cbsz 于 2012-1-4 19:19 编辑

弄的太麻烦了吧？看看这个怎么样？
(DEFUN C:KK (/ PNT PICKCIRCLE GR FLAG)
       (SETQ PNT (CADR (GRREAD T)))
       (SETQ PICKCIRCLE (LIST '(0 . "CIRCLE") '(100 . "AcDbEntity") '(67 . 0) '(8 . "0") '(100 . "AcDbCircle")
          (APPEND (LIST 10) PNT) '(40 . 1000)));END_SETQ
       (ENTMAKE PICKCIRCLE)
       (SETQ FLAG nil)
(WHILE (NOT FLAG)
       (SETQ GR (GRREAD T))
       (COND
       ((= (CAR GR) 5)
         (ENTMOD (SUBST (APPEND (LIST 10) (CADR (GRREAD T))) (ASSOC 10 (ENTGET (ENTLAST))) (ENTGET (ENTLAST)))))
       (T (PROGN (SETQ FLAG T) (ENTDEL (ENTLAST)))));END_COND
       );END_WHILE
      (PRINC)
      )

vlisp2012 发表于 2012-1-4 19:42:32

楼上的，不好用啊？！

江湖远人 发表于 2012-3-8 09:45:16

多谢开心楼主分享，收藏了

zyhandw 发表于 2012-11-1 09:37:31

的确有很多问题，比如：选择的对象是mtext，mtext对象就会变没有了;选择的是直线的话，直线的一个顶点跟着走;选择多段线时也有问题等等

成仔 发表于 2012-11-1 18:55:12

貌似挺有意思的，不过用处不大

igumu 发表于 2012-11-2 15:50:47

貌似挺有意思的，不过用处不大
页: [1] 2
查看完整版本: 动态对象跟着鼠标走