grread捕捉

;;;gxl-ge-grread 自定义带捕捉的grread函数
;;;参数:gr_mode = 函数grread的参数表 如: (list [track] [allkeys [curtype]),参数个数按需要设置，可为nil
;;;     startpt = 基点，计算垂足点、正交模式等坐标的基点,若为nil,则基点默认为系统变量lastpoint值
;;;     ss = 捕捉避开的物体，可以是选择集或图元名
(defun gxl-ge-grread (gr_mode   startptss
     /   get_osmode getgrvecs
     drawvecs   time f3
     f8   str_osmode lst_osmode
     draftobj   autosnapmarkersize
     autosnapmarkercolordrag
     dragmode   ghostpt x0
     y0   x1 y1
     z1   distperpixel bold
    )
;;;==================================================================
  ;;gxl-sel-redrawsel 重画选择集中的对象，sel 为选择集或图元名 mode 为方式码
;;;重画选择集中的对象，mode 为方式码，
;;;方式码 1 在屏幕重画该选择集对象
;;;方式码 2 隐藏该选择集对象
;;;方式码 3 “醒目显示”该选择集对象
;;;方式码 4 取消“醒目显示”该选择集对象
;;;==================================================================
  (defun gxl-sel-redrawsel (sel mode / m n)
    (if sel
      (progn
(cond ((= 'pickset (type sel))
      (setq m (sslength sel)
    n 0
      )
      (repeat m
(redraw (ssname sel n) mode)
(setq n (1+ n))
      )
     )
     ((= 'ename (type sel))
      (redraw sel mode)
     )
)
      )
    )
  ) ;defun gxl-sel-redrawsel


;;;分列字串
  (defun gxl-strparse (str del / pos lst)
    (while (setq pos (vl-string-search del str))
      (setq lst (cons (substr str 1 pos) lst)
   str (substr str (+ pos 1 (strlen del)))
      )
    )
    (if (= " " del)
      (vl-remove "" (reverse (cons str lst)))
      (reverse (cons str lst))
    )
  )
;;;返回捕捉模式字串
  (defun get_osmode (/ cur_mode mode$)
    (setq mode$ "")
    (if (< 0 (setq cur_mode (getvar "osmode")) 16384)
      (mapcar (function (lambda(x)
 (if (not (zerop (logand cur_mode (car x))))
   (if (zerop (strlen mode$))
     (setq mode$ (cadr x))
     (setq mode$ (strcat mode$ "," (cadr x)))
   )
 )
)
     )
     '((1 "_end")
(2 "_mid")
(4 "_cen")
(8 "_nod")
(16 "_qua")
(32 "_int")
(64 "_ins")
(128 "_per")
(256 "_tan")
(512 "_nea")
(1024 "_qui")
(2048 "_app")
(4096 "_ext")
(8192 "_par")
      )
      )
    )
    mode$
  )
;;;返回捕捉标记vecs
  (defun getgrvecs (pt dragpt lst / key)
    (setq key t)
    (while (and key lst)
      (if (equal (osnap dragpt (car lst)) pt 1e-6)
(setq key nil)
(setq lst (cdr lst))
      )
    )
    (cdr (assoc (car lst)
'(("_end"
  ((-1 1) (-1 -1))
  ((-1 -1) (1 -1))
  ((1 -1) (1 1))
  ((1 1) (-1 1))
 ) ;正方形 
 ("_mid"
  ((0 1.414) (-1.225 -0.707))
  ((-1.225 -0.707) (1.225 -0.707))
  ((1.225 -0.707) (0 1.414))
 ) ;三角形 
 ("_cen"
  ((0 1) (-0.707 0.707))
  ((-0.707 0.707) (-1 0))
  ((-1 0) (-0.707 -0.707))
  ((-0.707 -0.707) (0 -1))
  ((0 -1) (0.707 -0.707))
  ((0.707 -0.707) (1 0))
  ((1 0) (0.707 0.707))
  ((0.707 0.707) (0 1))
 ) ;圆 
 ("_nod"
  ((0 1) (-0.707 0.707))
  ((-0.707 0.707) (-1 0))
  ((-1 0) (-0.707 -0.707))
  ((-0.707 -0.707) (0 -1))
  ((0 -1) (0.707 -0.707))
  ((0.707 -0.707) (1 0))
  ((1 0) (0.707 0.707))
  ((0.707 0.707) (0 1))
  ((-1 1) (1 -1))
  ((-1 -1) (1 1))
 ) ;圆+十字交叉 
 ("_qua"
  ((0 1.414) (-1.414 0))
  ((-1.414 0) (0 -1.414))
  ((0 -1.414) (1.414 0))
  ((1.414 0) (0 1.414))
 ) ;旋转45°的正方形 
 ("_int"
  ((-1 1) (1 -1))
  ((-1 -1) (1 1))
  ((1 0.859) (-0.859 -1))
  ((-1 0.859) (0.859 -1))
  ((0.859 1) (-1 -0.859))
  ((-0.859 1) (1 -0.859))
 ) ;十字交叉 
 ("_ins"
  ((-1 1) (-1 -0.1))
  ((-1 -0.1) (0 -0.1))
  ((0 -0.1) (0 -1.0))
  ((0 -1.0) (1 -1))
  ((1 -1) (1 0.1))
  ((1 0.1) (0 0.1))
  ((0 0.1) (0 1.0))
  ((0 1.0) (-1 1))
 ) ;两个正方形 
 ("_per"
  ((-1 1) (-1 -1))
  ((-1 -1) (1 -1))
  ((0 -1) (0 0))
  ((0 0) (-1 0))
 ) ;半个正方形 
 ("_tan"
  ((0 1) (-0.707 0.707))
  ((-0.707 0.707) (-1 0))
  ((-1 0) (-0.707 -0.707))
  ((-0.707 -0.707) (0 -1))
  ((0 -1) (0.707 -0.707))
  ((0.707 -0.707) (1 0))
  ((1 0) (0.707 0.707))
  ((0.707 0.707) (0 1))
  ((1 1) (-1 1))
 ) ;园+线 
 ("_nea"
  ((-1 1) (1 -1))
  ((1 -1) (-1 -1))
  ((-1 -1) (1 1))
  ((1 1) (-1 1))
 ) ;两个三角形
 ("_qui") ; ??? 
 ("_app"
  ((-1 1) (-1 -1))
  ((-1 -1) (1 -1))
  ((1 -1) (1 1))
  ((1 1) (-1 1))
  ((-1 1) (1 -1))
  ((-1 -1) (1 1))
 ) ;正方形+十字交叉 
 ("_ext"
  ((0.1 0) (0.13 0))
  ((0.2 0) (0.23 0))
  ((0.3 0) (0.33 0))
 ) ;三个点 
 ("_par" ((0 1) (-1 -1)) ((1 1) (0 -1))) ;两条线


)
)
    )
  )
  ;;绘制捕捉标记 
  (defun drawvecs (pt vecs size color / lst xdir)
    (setq xdir (getvar 'ucsxdir))
    (setq vecs
  (mapcar
    '(lambda (x)
(mapcar '(lambda (a)
  (setq a (trans a 0 xdir))
  (setq a (list (caddr a) (car a)))
  (list (+ (car pt) (* size (car a)))
(+ (cadr pt) (* size (cadr a)))
  )
)
x
)
     )
    vecs
  )
    )
    (setq lst (mapcar 'cons
     (mapcar (function (lambda (x) color)) vecs)
     vecs
     )
    )
    (grvecs (apply 'append lst))
  )
;;;主程序开始
  (vl-load-com)
  (if startpt
    (setvar 'lastpoint startpt)
    (setq startpt (getvar 'lastpoint))
  )
  (setq time t)
  (setq f3 (getvar "osmode"))
  (setq f8 (getvar "orthomode"))
  (setq str_osmode (get_osmode))
  (setq lst_osmode (gxl-strparse str_osmode ","))
  (setq draftobj (vla-get-drafting
  (vla-get-preferences (vlax-get-acad-object))
)
  )
  (setq autosnapmarkersize (vla-get-autosnapmarkersize draftobj))
  (setq autosnapmarkercolor (vla-get-autosnapmarkercolor draftobj))
  (setq drag (apply 'grread gr_mode)) ;_ 执行gread函数
  (setq dragmode (car drag))
  (cond
    ((equal drag '(2 6)) ;f3切换捕捉开关
     (if (< f3 16384)
       (progn (setq f3 (+ f3 16384)) (prompt "\n<对象捕捉 关>"))
       (progn (setq f3 (- f3 16384)) (prompt "\n<对象捕捉 开>"))
     )
     (setvar "osmode" f3)
     (redraw)
    )
    ((equal drag '(2 15)) ;f8切换正交开关
     (if (= f8 0)
       (progn (setq f8 1) (prompt "\n<正交 开>"))
       (progn (setq f8 0) (prompt "\n<正交 关>"))
     )
     (setvar "orthomode" f8)
     (redraw)
    )
    ((= dragmode 5)
     (redraw)
     (gxl-sel-redrawsel ss 2) ;_ 隐藏选择集
     (setq drag (cadr drag))
     (if (or (zerop (strlen str_osmode))
    (null (setq ghostpt (osnap drag str_osmode)))
)
;;;此处修改正交模式下坐标
       (if (and startpt (= 1 f8) (/= 2 (car drag)))
(progn
  (setq x0 (car startpt)
y0 (cadr startpt)
x1 (car drag)
y1 (cadr drag)
z1 (caddr drag)
  )
  (if (> (abs (- x0 x1)) (abs (- y0 y1)))
    (setq ghostpt (list x1 y0 z1))
    (setq ghostpt (list x0 y1 z1))
  )
)
(setq ghostpt drag)
       )
       ;;beacuse of mouse middle button scroll , calculate "distperpixel" every time 
       (progn
(setq distperpixel
(/ (getvar "viewsize")
  (cadr (getvar "screensize"))
)
)
;;bold 
(setq
  bold (mapcar '*
(list distperpixel distperpixel distperpixel)
(list (+ autosnapmarkersize 0.5)
     autosnapmarkersize
     (- autosnapmarkersize 0.5)
)
)
)
(foreach item bold
  (drawvecs
    ghostpt
    (getgrvecs ghostpt drag lst_osmode)
    item
    autosnapmarkercolor
  )
)
       )
     )
     (gxl-sel-redrawsel ss 1) ;_ 显示选择集
    )
    ((or (= dragmode 3)
(= dragmode 12)
     )
     (gxl-sel-redrawsel ss 2) ;_ 隐藏选择集
     (if (null (setq ghostpt (osnap (cadr drag) (get_osmode))))
;;;此处修改正交模式下坐标
       (if (and startpt (= 1 f8) (/= 2 (car drag)))
(progn
  (setq x0 (car startpt)
y0 (cadr startpt)
x1 (caadr drag)
y1 (cadadr drag)
z1 (caddar (cdr drag))
  )
  (if (> (abs (- x0 x1)) (abs (- y0 y1)))
    (setq ghostpt (list x1 y0 z1))
    (setq ghostpt (list x0 y1 z1))
  )
)
(setq ghostpt (cadr drag))
       )


     )
     (redraw)
     (gxl-sel-redrawsel ss 1) ;_ 显示选择集
     (setq time nil)


    )
    (t
;;;此处修改正交模式下坐标
     (if (and startpt (= 1 f8) (/= 2 (car drag)))
       (progn
(setq x0 (car startpt)
      y0 (cadr startpt)
      x1 (caadr drag)
      y1 (cadadr drag)
      z1 (caddar (cdr drag))
)
(if (> (abs (- x0 x1)) (abs (- y0 y1)))
  (setq ghostpt (list x1 y0 z1))
  (setq ghostpt (list x0 y1 z1))
)
       )
       (setq ghostpt (cadr drag))
     )
     (redraw)
    )
  )
; ) 
  (list dragmode ghostpt)
)
;;;测试1，动态移动
(defun c:tt (/ ss pt p oldpt)
  (princ "\n选择移动物体: ")
  (while (not (setq ss (ssget))))
  (setq pt (getpoint "\n 选择基点"))
  (if (null pt)
    (setq oldpt (getvar 'lastpoint))
    (setq oldpt pt)
  )
  (while (/= 3 (car (setq gr (gxl-ge-grread '(t 7 2) pt ss)))) ;_ 将移动的选择集排除在捕捉目标之外
    (if (= 'list (type (setq p (cadr gr))))
      (progn
(grdraw pt p 1)
(command "move" ss "" oldpt p)
(setq oldpt p)
      )
    )
  )
)
;;;测试2
(defun c:test (/ en gr p enl)
  (while (not (setq p (getpoint "\n点："))))
  (while (/= 3 (car (setq gr (gxl-ge-grread '(t 7 2) p en)))) ;_ 将直线排除在捕捉目标之外
    (if (= 'list (type (cadr gr)))
      (progn
(if en
 (progn
   (entmod
     (subst (cons 11 (trans (cadr gr) 1 0)) (assoc 11 enl) enl)
   )
 )
 (progn
   (vla-addline
     (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
     )
     (vlax-3d-point (trans p 1 0))
     (vlax-3d-point (trans (cadr gr) 1 0))
   )
   (setq en  (entlast)
 enl (entget en)
   )
 )
)
      )
    )
  )
)