grread之历史开发经验剖析

尘缘一生 · 发表于 2024-6-30 05:44

本帖最后由尘缘一生于 2024-7-1 01:06 编辑

如题，那么三领哪，在这个问题上，一直再完善改进，说下子自己对这个问题的理解。
一：如图所示

当我们对选择集进行变换时候，集成热键开关，是很方便的，实际上，任何二开，这个是需要作的，并且是一定要做好的！！
比如：当我们复制选择集时，按下TAB键，就转90度，当然转了文字会不符合书写，比如块内文字。集成文字归正，一并解决。
注：经过历史测试，选择集采用函数去变换，还不如COMMAND速度高效。令外，选择集可以做成块，再作这个功能，是另一办法，代码在“五”项展示
二：代码

;;移动-拷贝-旋转-镜像-递增-放缩------(一级)---------
;三领设计 V3.0 Modify by 尘缘一生 QQ:15290049 2024.6.30 (精简后代码)
;;ss:实体、实体表、选择集 p0 移动起点 nil | k: t(move) nil(copy)
(defun sldomov (ss p0 k / e_lst p1 p2 pt pt1 loop ang dis f3 f8 bb p00 a b e1 ee)
(setq e_lst (sysvar '("QAFLAGS" "CMDECHO" "NOMUTT" "OSMODE" "ORTHOMODE")))
(cond
((= (type ss) 'ENAME) (setq ss (ssadd ss))) ;图元
((= (type ss) 'LIST) (setq ss (sl:pickset-fromlist ss))) ;实体表
)
(command "_.undo" "be") ;;舍弃高级代码,加速
(setvar "CMDECHO" 0) ;;命令显示关闭
(setvar "NOMUTT" 1)
(setvar "QAFLAGS" 0)
(if (= p0 nil)
(setq p0 (ssmpt ss)) ;选择集之中心
)
(princ
"\n->[逆转90度(TAB)/取角(A)/LIN.(E)/<-mir->(D)/↑mir ↓(S)/放大(Q)/缩小(W)/递增(Z)/递减(J)/大一倍(+)/小一半(-)/复制当前(C)/基点(X)/正交(F8)/扑捉(F3)](空格..复制)(左键>当前)(右键>退出)"
)
(setq loop t pt1 p0 p2 p0 f8 (getvar "ORTHOMODE") f3 (getvar "OSMODE"))
(while loop
(setq bb (grread t 15 2) p00 (cadr bb))
(cond
((equal bb '(2 6));F3切换捕捉开关
(cond
((and (< f3 16384) (/= f3 0))
(setq f3 (+ f3 16384))
(prompt "\n <对象捕捉关>")
)
((or (= f3 0) (>= f3 16384))
(setq f3 16383)
(prompt "\n <对象捕捉开>")
)
)
(setvar "OSMODE" f3) (redraw)
)
((equal bb '(2 15)) ;F8切换正交开关
(if (= f8 0)
(progn (setq f8 1) (prompt "\n <正交开>"))
(progn (setq f8 0) (prompt "\n <正交关>"))
)
(setvar "ORTHOMODE" f8) (redraw)
)
((= (car bb) 5)
(redraw)
(if (= f8 1)
(progn
(setq ang (angle p2 p00)) ;注意：凡正交，P2点比较的，必须是WHILE循坏外的固定点，循环体内P2若有新值，程序会在过程中重新正交定位位置了就
(cond
((or (and (> ang pi4) (< ang 3pi4)) (and (> ang 5pi4) (< ang 7pi4)))
(setq pt (list (car p2) (cadr p00)))
)
(t
(setq pt (list (car p00) (cadr p2)))
)
)
)
(setq pt p00)
)
(if (and (<= f3 16384) (> f3 0) (/= f8 1))
(setq pt (slosnappt ss pt)) ;slosnappt 扑捉函数，很遗憾，目前没有解决扑捉象限点问题
)
(if (> (distance p0 pt) 0.001)
(command "move" ss "" "_non" p0 "_non" pt)
)
(setq p0 pt)
)
((member bb '((2 9))) ;;table 键
(command "ROTATE" ss "" "_non" pt 90)
(setq ss (sl-wzgz ss))
)
((member bb '((2 65) (2 97))) ;;A 旋转定角
(ss-rotang ss 0) ;选择集先转0度水平
(setq a (ss9pt ss 1))
(setq b (polar a 0 500))
(command ".rotate" ss "" "_non" a "r" "_non" a (polar pt (angle pt b) (distance pt b)) pause)
(setq ss (sl-wzgz ss));sl-wzgz 文字归正函数，凡是有旋转操作的，都需要对选择集里面的文字书写归正，以下同。
)
((member bb '((2 115) (2 83))) ;;S s 上下翻
(command "mirror" ss "" "_non" pt (mapcar '- pt '(1 0)) "Y")
)
((member bb '((2 100) (2 68))) ;;D d 左右翻
(command "mirror" ss "" "_non" pt (mapcar '- pt '(0 1)) "Y")
)
((or (member bb '((2 13))) (= (car bb) 3));;左键、回车
(if (= k t) ;;移动
(setq loop nil)
(progn
(command "copy" ss "" "_non" '(0 0) "_non" '(0 0))
(setq ang (angle pt1 pt) dis (distance pt1 pt) pt1 pt)
)
)
)
((member bb '((2 69) (2 101))) ;;E e 齐线
(setq ss (ss-rotang ss 0)) ;选择集齐线，当首先选择集变水平0度
(setq e1 (car (setq ee (entsel "\n -->请选择要对齐的实体"))))
(setq ang (e-ang e1 (cadr ee))) ;取实体的角度集成
(setq ss (ss-rotang ss ang)) ;此时作齐线
(setq ss (sl-wzgz ss)) ;sl-wzgz 文字归正函数，凡是有旋转操作的，都需要对选择集里面的文字书写归正，以下同。
)
((member bb '((2 67) (2 99))) ;;C c 复制在当前
(command "copy" ss "" "_non" '(0 0) "_non" '(0 0))
(setq ang (angle pt1 pt) dis (distance pt1 pt) pt1 pt)
)
((and (member bb '((2 32))) ang dis) ;;空格键
(command "copy" ss "" "_non" '(0 0) "_non" '(0 0))
(command "MOVE" ss "" "_non" pt1 "_non" (setq pt1 (polar pt1 ang dis))) ;;移位
)
((member bb '((2 87) (2 119))) ;;缩小 W w
(command "scale" ss "" "_non" pt "0.9")
)
((member bb '((2 81) (2 113))) ;;放大 Q q
(command "scale" ss "" "_non" pt "1.1")
)
((equal bb '(2 45)) ;;缩小一半 -
(command "scale" ss "" "_non" pt "0.5")
)
((member bb '((2 43) (2 61))) ;;放大一倍 +
(command "scale" ss "" "_non" pt "2.0")
)
((member bb '((2 90) (2 122))) ;;递增 Z z
(setq ss (ss++ ss 1)) ;尾部递增，请自理即可
)
((member bb '((2 74) (2 106))) ;;递减 J j
(setq ss (ss++ ss -1));尾部递减，请自理即可
)
((member bb '((2 88) (2 120))) ;;基点 X x
(command "MOVE" ss "" "_non" pt "_non" p0) ;;移回去
(setq p1 (getpoint "\n 基点"))
(command "MOVE" ss "" "_non" p1 "_non" p0)
)
((or t (member (car bb) '(11 25)));;右键其余键
(if (= k t) ;;移动
(command "MOVE" ss "" "_non" pt "_non" p0) ;;移回去
(sl:erase ss) ;很明显，删除ss
)
(setq loop nil)
)
)
)
(redraw)
(command "_.undo" "e")
(mapcar 'eval e_lst)
(princ)
)
;;!!!!!!!!!!!!!!!!!!!!!!!!
;;构造命令调用它的使用方法
;;点移---------
(defun c:d-mov (/ s)
(if (setq s (ssget))
(sldomov s (cadr (grread 5)) t)
)
)
;;重复点移----
(defun c:dd-mov (/ s)
(while (setq s (ssget ":S"))
(sldomov s (cadr (grread 5)) t)
)
)
;;点拷--------
(defun c:d-cop (/ s)
(if (setq s (ssget))
(progn
(command "copy" s "" "_non" '(0 0) "_non" '(0 0))
(sldomov s (cadr (grread 5)) nil)
)
)
)
;;重复点拷----
(defun c:dd-cop (/ s)
(while (setq s (ssget ":S"))
(command "copy" s "" "_non" '(0 0) "_non" '(0 0))
(sldomov s (cadr (grread 5)) t)
)
)

;;移动-拷贝-旋转-镜像-递增-放缩------(一级)--------- 
;三领设计 V3.0 Modify by 尘缘一生  QQ:15290049 2024.6.30  (精简后代码) 
;;ss:实体、实体表、选择集 p0 移动起点 nil | k: t(move) nil(copy) 
(defun sldomov (ss p0 k / e_lst p1 p2 pt pt1 loop ang dis f3 f8 bb p00 a b e1 ee) 
  (setq e_lst (sysvar '("QAFLAGS" "CMDECHO" "NOMUTT" "OSMODE" "ORTHOMODE"))) 
  (cond 
    ((= (type ss) 'ENAME) (setq ss (ssadd ss))) ;图元 
    ((= (type ss) 'LIST) (setq ss (sl:pickset-fromlist ss))) ;实体表 
  ) 
  (command "_.undo" "be") ;;舍弃高级代码,加速 
  (setvar "CMDECHO" 0) ;;命令显示关闭 
  (setvar "NOMUTT" 1) 
  (setvar "QAFLAGS" 0) 
  (if (= p0 nil) 
    (setq p0 (ssmpt ss)) ;选择集之中心 
  ) 
  (princ 
    "\n->[逆转90度(TAB)/取角(A)/LIN.(E)/<-mir->(D)/↑mir ↓(S)/放大(Q)/缩小(W)/递增(Z)/递减(J)/大一倍(+)/小一半(-)/复制当前(C)/基点(X)/正交(F8)/扑捉(F3)](空格..复制)(左键>当前)(右键>退出)" 
  ) 
  (setq loop t pt1 p0 p2 p0 f8 (getvar "ORTHOMODE") f3 (getvar "OSMODE")) 
  (while loop 
    (setq bb (grread t 15 2) p00 (cadr bb)) 
    (cond 
      ((equal bb '(2 6));F3切换捕捉开关 
        (cond 
          ((and (< f3 16384) (/= f3 0)) 
            (setq f3 (+ f3 16384)) 
            (prompt "\n <对象捕捉 关>") 
          ) 
          ((or (= f3 0) (>= f3 16384)) 
            (setq f3 16383) 
            (prompt "\n <对象捕捉 开>") 
          ) 
        ) 
        (setvar "OSMODE" f3) (redraw) 
      )    
      ((equal bb '(2 15))    ;F8切换正交开关 
        (if (= f8 0) 
          (progn (setq f8 1) (prompt "\n <正交 开>")) 
          (progn (setq f8 0) (prompt "\n <正交 关>")) 
        ) 
        (setvar "ORTHOMODE" f8) (redraw) 
      ) 
      ((= (car bb) 5) 
        (redraw) 
        (if (= f8 1) 
          (progn 
            (setq ang (angle p2 p00)) ;注意：凡正交，P2点比较的，必须是WHILE循坏外的固定点，循环体内P2若有新值，程序会在过程中重新正交定位位置了就 
            (cond 
              ((or (and (> ang pi4) (< ang 3pi4)) (and (> ang 5pi4) (< ang 7pi4))) 
                (setq pt (list (car p2) (cadr p00))) 
              ) 
              (t 
                (setq pt (list (car p00) (cadr p2))) 
              ) 
            ) 
          ) 
          (setq pt p00) 
        ) 
        (if (and (<= f3 16384) (> f3 0) (/= f8 1)) 
          (setq pt (slosnappt ss pt)) ;slosnappt 扑捉函数，很遗憾，目前没有解决扑捉象限点问题 
        ) 
        (if (> (distance p0 pt) 0.001) 
          (command "move" ss "" "_non" p0 "_non" pt) 
        )   
        (setq p0 pt) 
      ) 
      ((member bb '((2 9)))      ;;table 键 
        (command "ROTATE" ss "" "_non" pt 90) 
        (setq ss (sl-wzgz ss)) 
      ) 
      ((member bb '((2 65) (2 97)))   ;;A 旋转定角 
        (ss-rotang ss 0) ;选择集先转0度水平 
        (setq a (ss9pt ss 1)) 
        (setq b (polar a 0 500)) 
        (command ".rotate" ss "" "_non" a "r" "_non" a (polar pt (angle pt b) (distance pt b)) pause) 
        (setq ss (sl-wzgz ss));sl-wzgz  文字归正函数，凡是有旋转操作的，都需要对选择集里面的文字书写归正，以下同。 
      ) 
      ((member bb '((2 115) (2 83)))  ;;S s 上下翻 
        (command "mirror" ss "" "_non" pt (mapcar '- pt '(1 0)) "Y") 
      ) 
      ((member bb '((2 100) (2 68))) ;;D d 左右翻 
        (command "mirror" ss "" "_non" pt (mapcar '- pt '(0 1)) "Y") 
      ) 
      ((or (member bb '((2 13))) (= (car bb) 3));;左键、回车 
        (if (= k t) ;;移动 
          (setq loop nil) 
          (progn 
            (command "copy" ss "" "_non" '(0 0) "_non" '(0 0)) 
            (setq ang (angle pt1 pt) dis (distance pt1 pt) pt1 pt) 
          ) 
        ) 
      ) 
      ((member bb '((2 69) (2 101)))   ;;E e 齐线 
        (setq ss (ss-rotang ss 0)) ;选择集齐线，当首先选择集变水平0度 
        (setq e1 (car (setq ee (entsel "\n -->请选择要对齐的实体")))) 
        (setq ang (e-ang e1 (cadr ee))) ;取实体的角度集成 
        (setq ss (ss-rotang ss ang)) ;此时作齐线 
        (setq ss (sl-wzgz ss)) ;sl-wzgz  文字归正函数，凡是有旋转操作的，都需要对选择集里面的文字书写归正，以下同。 
      ) 
      ((member bb '((2 67) (2 99)))   ;;C c 复制在当前 
        (command "copy" ss "" "_non" '(0 0) "_non" '(0 0)) 
        (setq ang (angle pt1 pt) dis (distance pt1 pt) pt1 pt) 
      ) 
      ((and (member bb '((2 32))) ang dis) ;;空格键 
        (command "copy" ss "" "_non" '(0 0) "_non" '(0 0)) 
        (command "MOVE" ss "" "_non" pt1 "_non" (setq pt1 (polar pt1 ang dis))) ;;移位 
      ) 
      ((member bb '((2 87) (2 119)))         ;;缩小  W w 
        (command "scale" ss "" "_non" pt "0.9") 
      ) 
      ((member bb '((2 81) (2 113)))         ;;放大  Q q 
        (command "scale" ss "" "_non" pt "1.1") 
      ) 
      ((equal bb '(2 45))         ;;缩小一半 - 
        (command "scale" ss "" "_non" pt "0.5") 
      ) 
      ((member bb '((2 43) (2 61))) ;;放大一倍 + 
        (command "scale" ss "" "_non" pt "2.0") 
      ) 
      ((member bb '((2 90) (2 122)))  ;;递增 Z z 
        (setq ss (ss++ ss 1)) ;尾部递增，请自理即可 
      ) 
      ((member bb '((2 74) (2 106)))  ;;递减 J j 
        (setq ss (ss++ ss -1));尾部递减，请自理即可 
      ) 
      ((member bb '((2 88) (2 120)))  ;;基点 X x 
        (command "MOVE" ss "" "_non" pt "_non" p0)  ;;移回去 
        (setq p1 (getpoint "\n 基点")) 
        (command "MOVE" ss "" "_non" p1 "_non" p0) 
      ) 
      ((or t (member (car bb) '(11 25)));;右键 其余键 
        (if (= k t) ;;移动 
          (command "MOVE" ss "" "_non" pt "_non" p0)  ;;移回去 
          (sl:erase ss) ;很明显，删除ss 
        ) 
        (setq loop nil) 
      ) 
    ) 
  ) 
  (redraw) 
  (command "_.undo" "e") 
  (mapcar 'eval e_lst) 
  (princ) 
) 
;;!!!!!!!!!!!!!!!!!!!!!!!! 
;;构造命令调用它的使用方法 
;;点移--------- 
(defun c:d-mov (/ s) 
  (if (setq s (ssget)) 
    (sldomov s (cadr (grread 5)) t) 
  ) 
) 
;;重复点移---- 
(defun c:dd-mov (/ s) 
  (while (setq s (ssget ":S")) 
    (sldomov s (cadr (grread 5)) t) 
  ) 
) 
;;点拷-------- 
(defun c:d-cop (/ s) 
  (if (setq s (ssget)) 
    (progn 
      (command "copy" s "" "_non" '(0 0) "_non" '(0 0)) 
      (sldomov s (cadr (grread 5)) nil) 
    ) 
  ) 
) 
;;重复点拷---- 
(defun c:dd-cop (/ s) 
  (while (setq s (ssget ":S")) 
    (command "copy" s "" "_non" '(0 0) "_non" '(0 0)) 
    (sldomov s (cadr (grread 5)) t) 
  ) 
)

三：grread下的扑捉函数
也就是这个函数，不支持扑捉象限点 QUA 16，虽然代码包含，但无效，为什么呢？窃以为因为当鼠标移到比时：如圆附近时，扑捉的是NEA了。本坛至少3个版本这个问题，没有一个支持的。三领也尚未解决。
考虑这个问题需要附带再开发，采取包容盒取中点来作，留待时日吧......

;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun slosnappt (name pt / p mode osmod osmode size)
(defun sldectobin (n m / c f) ;;十进制转二进制
(setq f (if (< n 0) 1 0) n (abs n))
(while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
(while (< (length c) (1- m)) (setq c (cons 0 c)))
(cons f c)
)
;;------------------
(defun sldrawvecs (pt vecs size color / xdir)
(setq xdir (getvar 'ucsxdir)
vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs)
)
(grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) color)) vecs) vecs)))
)
;;----------------
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(cond
((= (type name) 'ENAME) (entdel name)) ;图元先删除
((= (type name) 'PICKSET) ;选择集
(sl-sel-redrawsel name 2) ;先隐藏
)
)
(if (setq
osmod '("_END," "_MID," "_CEN," "_NOD," "_QUA," "_INT," "_INS," "_PER," "_TAN," "_NEA," "_APP," "_EXT," "_PAR")
osmode (reverse (sldectobin (getvar 'osmode) 1))
size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
mode (cdr (assoc (if p
(vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
(vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
)
'(("_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)))
("_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)))
("_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)))
)
)
)
)
(sldrawvecs (setq p (if p p pt)) mode size (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))))
)
(cond
((= (type name) 'ENAME) (entdel name)) ;图元恢复
((= (type name) 'PICKSET) ;选择集
(sl-sel-redrawsel name 1) ;恢复显示
)
)
)
)
(if p p pt)
)

;;grread图元捕捉子函数-----(一级)------ 
;;name为移动的图元、选择集,pt为光标点 
;;有捕捉点则返回捕捉点,无返回光标点 
(defun slosnappt (name pt / p mode osmod osmode size) 
  (defun sldectobin (n m / c f) ;;十进制转二进制 
    (setq f (if (< n 0) 1 0) n (abs n)) 
    (while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0)) 
    (while (< (length c) (1- m)) (setq c (cons 0 c))) 
    (cons f c) 
  ) 
  ;;------------------ 
  (defun sldrawvecs (pt vecs size color / xdir) 
    (setq xdir (getvar 'ucsxdir) 
      vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs) 
    ) 
    (grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) color)) vecs) vecs))) 
  ) 
  ;;---------------- 
  (if (< (getvar "OSMODE") 16384) ;;打开捕捉 
    (progn 
      (cond 
        ((= (type name) 'ENAME) (entdel name)) ;图元先删除 
        ((= (type name) 'PICKSET) ;选择集 
          (sl-sel-redrawsel name 2) ;先隐藏 
        ) 
      ) 
      (if (setq 
            osmod '("_END," "_MID," "_CEN," "_NOD," "_QUA," "_INT," "_INS," "_PER," "_TAN," "_NEA," "_APP," "_EXT," "_PAR") 
            osmode (reverse (sldectobin (getvar 'osmode) 1)) 
            size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")) 
            p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod))) 
            mode (cdr (assoc (if p 
                               (vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x))) 
                                 (vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod))) 
                             ) 
                        '(("_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))) 
                           ("_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))) 
                           ("_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))) 
                         ) 
                      ) 
                 ) 
          ) 
        (sldrawvecs (setq p (if p p pt)) mode size (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))) 
      ) 
      (cond 
        ((= (type name) 'ENAME) (entdel name)) ;图元恢复 
        ((= (type name) 'PICKSET) ;选择集 
          (sl-sel-redrawsel name 1) ;恢复显示 
        ) 
      ) 
    ) 
  ) 
  (if p p pt) 
)

四：展示功能
下面是对一个成块的表格操作

展示了TAB键时候的效果，大家可以看到文字始终是正的；
展示了E热键对它齐线角度的效果

五：以块为基础的这个问题的集成（方法函数之二）

;;铺捉、正交移动、复制、旋转、放缩....---(一级)----
;;ss: 图块选择集实体实体表 || p0:移动起点 or nil
;;(domov-os (setq ss (ssget)) p0)
;;图块返回图块 ;其他处理后选择集
;三领设计 V3.0 Modify by 尘缘一生 QQ:15290049 2024.6.30 (精简后代码)
(defun domov-os (ss p0 / e_lst p1 pt pt1 loop ang ang0 ang1 dis f3 f8 bb p10 p00 n e ee kk a b nam e1 ee)
(if (= p0 nil) (setq p0 (ssmpt ss)))
(if (null c:sl-tkgl)
(load (strcat sl-path0 "\\Support\" "sl-tkgl.VLX")) ;加载块处理集成罢了，自理
)
(setq e_lst (sysvar '("CMDECHO" "NOMUTT" "OSMODE" "ORTHOMODE")) ee (entlast))
(cond
((and (= (type ss) 'ENAME) (/= (dxf1 ss 0) "INSERT")) ;图元
(setq e (sl-sb (ssadd ss) p0) kk t) ;sl-sb 选择集做块
)
((and (= (type ss) 'ENAME) (= (dxf1 ss 0) "INSERT")) ;图块
(setq e ss kk nil)
)
((= (type ss) 'LIST) ;实体表
(setq ss (sl:pickset-fromlist ss))
(setq e (sl-sb ss p0) kk t)
)
((= (type ss) 'PICKSET) ;选择集
(if (> (sslength ss) 1)
(setq e (sl-sb ss p0) kk t)
)
(if (= (sslength ss) 1)
(progn
(setq nam (ssname ss 0))
(if (= (dxf1 nam 0) "INSERT")
(setq e nam kk nil)
(setq e (sl-sb ss p0) kk t)
)
)
)
)
)
(command "_.undo" "be")
(setvar "CMDECHO" 0)
(setvar "NOMUTT" 1)
(princ "\n->[逆转90度(TAB)/取角(A)/LIN.(E)/<-镜向->(D)/↑镜向 ↓(S)/放大(Q)/缩小(W)/大一倍(+)/小一半(-)/基点(X)/正交(F8)/扑捉(F3)](空格..复制)(左键插入)(右键退出)")
(setq loop t pt1 p0 p1 p0 ang 0 f8 (getvar "ORTHOMODE") f3 (getvar "OSMODE"))
(while loop
(setq bb (grread t 15 2) p00 (cadr bb))
(cond
((equal bb '(2 6)) ;F3切换捕捉开关
(cond
((and (< f3 16384) (/= f3 0))
(setq f3 (+ f3 16384))
(prompt "\n <对象捕捉关>")
)
((or (= f3 0) (>= f3 16384))
(setq f3 16383)
(prompt "\n <对象捕捉开>")
)
)
(setvar "OSMODE" f3) (redraw)
)
((equal bb '(2 15)) ;F8切换正交开关
(if (= f8 0)
(progn (setq f8 1) (prompt "\n <正交开>"))
(progn (setq f8 0) (prompt "\n <正交关>"))
)
(setvar "ORTHOMODE" f8) (redraw)
)
((= (car bb) 5)
(redraw)
(if (= f8 1)
(progn
(setq ang1 (angle p1 p00))
(cond
((or (and (> ang1 pi4) (< ang1 3pi4)) (and (> ang1 5pi4) (< ang1 7pi4)))
(setq pt (list (car p1) (cadr p00)))
)
(t
(setq pt (list (car p00) (cadr p1)))
)
)
)
(setq pt p00)
)
(if (> (/ (distance p0 p00) (getvar "VIEWSIZE")) 0.001)
(if (and (<= f3 16384) (> f3 0))
(sl_subupd e 10 (setq pt (slosnappt e pt)))
(sl_subupd e 10 pt)
)
)
(setq p0 pt)
)
((member bb '((2 9))) ;;table 键
(setq ang (+ ang pi2))
(sl_subupd e 50 ang)
(setq e (blkwzgz e)) ;块内文字实体角度归正，余同
)
((member bb '((2 65) (2 97))) ;;A 旋转定角
(redraw e 2)
(sl_subupd e 50 0)
(setq a (car (ebox4 e)))
(setq b (polar a 0 500))
(command ".rotate" e "" "_non" a "r" "_non" a (polar pt (angle pt b) (distance pt b)) pause)
(setq e (blkwzgz e))
)
((member bb '((2 69) (2 101))) ;;E e 齐线
(setq e1 (car (setq ee (entsel "\n -->请选择要对齐的实体"))))
(setq ang (e-ang e1 (cadr ee)))
(sl_subupd e 50 ang)
(setq e (blkwzgz e))
)
((member bb '((2 115) (2 83))) ;;S s 上下翻
(command "mirror" e "" "_non" pt (mapcar '- pt '(1 0)) "Y")
(setq e (blkwzgz e))
)
((member bb '((2 100) (2 68))) ;;D d 左右翻
(command "mirror" e "" "_non" pt (mapcar '- pt '(0 1)) "Y")
(setq e (blkwzgz e))
)
((or (member bb '((2 13))) (= (car bb) 3));;左键、回车
(command "copy" e "" "_non" '(0 0) "_non" '(0 0))
(setq e (entlast) p10 (dxf1 e 10))
(setq ang0 (angle pt1 p10) dis (distance pt1 p10) pt1 p10)
)
((and ang0 dis (member bb '((2 32)))) ;;空格键
(sl_subupd e 10 (setq p10 (polar p10 ang0 dis)))
(setq pt1 p10)
(command "copy" e "" "_non" '(0 0) "_non" '(0 0))
(setq e (entlast))
)
((member bb '((2 87) (2 119))) ;;缩小 W w
(command "scale" e "" "_non" pt "0.9")
)
((member bb '((2 81) (2 113))) ;;放大 Q q
(command "scale" e "" "_non" pt "1.1")
)
((equal bb '(2 45)) ;;缩小一半 -
(command "scale" e "" "_non" pt "0.5")
)
((member bb '((2 43) (2 61))) ;;放大一倍 +
(command "scale" e "" "_non" pt "2.0")
)
((member bb '((2 88) (2 120))) ;;基点 X x
(setq p0 (getpoint "\n 基点"))
(sl-blockbaseedit e p0)
)
((or t (member (car bb) '(11 25)));;右键其余键
(entdel e)
(setq loop nil)
)
)
)
(setq s (last_ent ee))
(if (= kk t) ;非块
(repeat (setq n (sslength s))
(vl-catch-all-apply 'exp-blk (list (ssname s (setq n (1- n))))) ;炸块集成，求得最后结果同
)
)
(command "_.undo" "e")
(mapcar 'eval e_lst)
ss
)

;;铺捉、正交移动、复制、旋转、放缩....---(一级)---- 
;;ss: 图块 选择集 实体 实体表 || p0:移动起点 or nil 
;;(domov-os (setq ss (ssget)) p0) 
;;图块返回图块 ;其他 处理后选择集 
;三领设计 V3.0 Modify by 尘缘一生  QQ:15290049 2024.6.30  (精简后代码) 
(defun domov-os (ss p0 / e_lst p1 pt pt1 loop ang ang0 ang1 dis f3 f8 bb p10 p00 n e ee kk a b nam e1 ee) 
  (if (= p0 nil) (setq p0 (ssmpt ss))) 
  (if (null c:sl-tkgl) 
    (load (strcat sl-path0 "\\Support\" "sl-tkgl.VLX")) ;加载块处理集成罢了，自理 
  ) 
  (setq e_lst (sysvar '("CMDECHO" "NOMUTT" "OSMODE" "ORTHOMODE")) ee (entlast)) 
  (cond 
    ((and (= (type ss) 'ENAME) (/= (dxf1 ss 0) "INSERT")) ;图元 
      (setq e (sl-sb (ssadd ss) p0) kk t) ;sl-sb 选择集做块 
    ) 
    ((and (= (type ss) 'ENAME) (= (dxf1 ss 0) "INSERT")) ;图块 
      (setq e ss kk nil) 
    ) 
    ((= (type ss) 'LIST) ;实体表 
      (setq ss (sl:pickset-fromlist ss)) 
      (setq e (sl-sb ss p0) kk t) 
    ) 
    ((= (type ss) 'PICKSET) ;选择集 
      (if (> (sslength ss) 1) 
        (setq e (sl-sb ss p0) kk t) 
      ) 
      (if (= (sslength ss) 1) 
        (progn 
          (setq nam (ssname ss 0)) 
          (if (= (dxf1 nam 0) "INSERT") 
            (setq e nam kk nil) 
            (setq e (sl-sb ss p0) kk t) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (command "_.undo" "be") 
  (setvar "CMDECHO" 0) 
  (setvar "NOMUTT" 1) 
  (princ "\n->[逆转90度(TAB)/取角(A)/LIN.(E)/<-镜向->(D)/↑镜向 ↓(S)/放大(Q)/缩小(W)/大一倍(+)/小一半(-)/基点(X)/正交(F8)/扑捉(F3)](空格..复制)(左键 插入)(右键 退出)") 
  (setq loop t pt1 p0 p1 p0 ang 0 f8 (getvar "ORTHOMODE") f3 (getvar "OSMODE")) 
  (while loop 
    (setq bb (grread t 15 2) p00 (cadr bb)) 
    (cond 
      ((equal bb '(2 6))    ;F3切换捕捉开关 
        (cond 
          ((and (< f3 16384) (/= f3 0)) 
            (setq f3 (+ f3 16384)) 
            (prompt "\n <对象捕捉 关>") 
          ) 
          ((or (= f3 0) (>= f3 16384)) 
            (setq f3 16383) 
            (prompt "\n <对象捕捉 开>") 
          ) 
        ) 
        (setvar "OSMODE" f3) (redraw) 
      )    
      ((equal bb '(2 15))    ;F8切换正交开关 
        (if (= f8 0) 
          (progn (setq f8 1) (prompt "\n <正交 开>")) 
          (progn (setq f8 0) (prompt "\n <正交 关>")) 
        ) 
        (setvar "ORTHOMODE" f8) (redraw) 
      ) 
      ((= (car bb) 5) 
        (redraw) 
        (if (= f8 1) 
          (progn 
            (setq ang1 (angle p1 p00)) 
            (cond 
              ((or (and (> ang1 pi4) (< ang1 3pi4)) (and (> ang1 5pi4) (< ang1 7pi4))) 
                (setq pt (list (car p1) (cadr p00))) 
              ) 
              (t 
                (setq pt (list (car p00) (cadr p1))) 
              ) 
            ) 
          ) 
          (setq pt p00) 
        ) 
        (if (> (/ (distance p0 p00) (getvar "VIEWSIZE")) 0.001) 
          (if (and (<= f3 16384) (> f3 0)) 
            (sl_subupd e 10 (setq pt (slosnappt e pt))) 
            (sl_subupd e 10 pt) 
          ) 
        ) 
        (setq p0 pt) 
      ) 
      ((member bb '((2 9)))  ;;table 键 
        (setq ang (+ ang pi2)) 
        (sl_subupd e 50 ang) 
        (setq e (blkwzgz e)) ;块内文字实体角度归正，余同 
      ) 
      ((member bb '((2 65) (2 97)))   ;;A 旋转定角 
        (redraw e 2) 
        (sl_subupd e 50 0) 
        (setq a (car (ebox4 e))) 
        (setq b (polar a 0 500)) 
        (command ".rotate" e "" "_non" a "r" "_non" a (polar pt (angle pt b) (distance pt b)) pause) 
        (setq e (blkwzgz e)) 
      ) 
      ((member bb '((2 69) (2 101)))   ;;E e 齐线 
        (setq e1 (car (setq ee (entsel "\n -->请选择要对齐的实体")))) 
        (setq ang (e-ang e1 (cadr ee))) 
        (sl_subupd e 50 ang) 
        (setq e (blkwzgz e)) 
      ) 
      ((member bb '((2 115) (2 83)))  ;;S s 上下翻 
        (command "mirror" e "" "_non" pt (mapcar '- pt '(1 0)) "Y") 
        (setq e (blkwzgz e)) 
      ) 
      ((member bb '((2 100) (2 68))) ;;D d 左右翻 
        (command "mirror" e "" "_non" pt (mapcar '- pt '(0 1)) "Y") 
        (setq e (blkwzgz e)) 
      ) 
      ((or (member bb '((2 13))) (= (car bb) 3));;左键、回车 
        (command "copy" e "" "_non" '(0 0) "_non" '(0 0)) 
        (setq e (entlast) p10 (dxf1 e 10)) 
        (setq ang0 (angle pt1 p10) dis (distance pt1 p10) pt1 p10) 
      ) 
      ((and ang0 dis (member bb '((2 32)))) ;;空格键 
        (sl_subupd e 10 (setq p10 (polar p10 ang0 dis))) 
        (setq pt1 p10) 
        (command "copy" e "" "_non" '(0 0) "_non" '(0 0)) 
        (setq e (entlast)) 
      ) 
      ((member bb '((2 87) (2 119)))         ;;缩小  W w 
        (command "scale" e "" "_non" pt "0.9") 
      ) 
      ((member bb '((2 81) (2 113)))         ;;放大  Q q 
        (command "scale" e "" "_non" pt "1.1") 
      ) 
      ((equal bb '(2 45))         ;;缩小一半 - 
        (command "scale" e "" "_non" pt "0.5") 
      ) 
      ((member bb '((2 43) (2 61))) ;;放大一倍 + 
        (command "scale" e "" "_non" pt "2.0") 
      ) 
      ((member bb '((2 88) (2 120)))  ;;基点 X x 
        (setq p0 (getpoint "\n 基点")) 
        (sl-blockbaseedit e p0) 
      ) 
      ((or t (member (car bb) '(11 25)));;右键 其余键 
        (entdel e) 
        (setq loop nil) 
      ) 
    ) 
  ) 
  (setq s (last_ent ee)) 
  (if (= kk t) ;非块 
    (repeat (setq n (sslength s)) 
      (vl-catch-all-apply 'exp-blk (list (ssname s (setq n (1- n))))) ;炸块集成，求得最后结果同 
    ) 
  ) 
  (command "_.undo" "e") 
  (mapcar 'eval e_lst) 
  ss 
)

三领设计 V3.0 永久下载地址：
链接：https://pan.baidu.com/s/1Gi84E8KkAfCwG3JJo1bDOg
提取码：2jsu

你有种再说一遍 · 发表于 2024-6-30 18:00

还好c#没有这个烦恼,直接用键盘钩子想怎么玩怎么玩...

liuhe · 发表于 2024-6-30 07:53

不要是试图用grread函数去搞捕捉了，捕捉的点都是不精准的点

尘缘一生 · 发表于 2024-7-3 00:11

本帖最后由尘缘一生于 2024-7-3 00:13 编辑

dtucad 发表于 2024-7-2 23:53
凑热闹（动图有点大，耐心等待）
纯LSP重写带捕捉的grread，支持各种捕捉(含象限点)、极轴、正交、 ...

你弄好了代码了？我还在考虑，今天又改写了下子，
我那边开了个新帖，为解决这个问题
我没有在函数本身解决问题，构造了个外壳，

;;grread图元捕捉函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
(defun sl-osnappt (pt / p mode osmod osmode size cl)
(defun sldectobin (n m / c f) ;;十进制转二进制
(setq f (if (< n 0) 1 0) n (abs n))
(while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0))
(while (< (length c) (1- m)) (setq c (cons 0 c)))
(cons f c)
)
;;------------------
(defun sldrawvecs (pt vecs size cl / xdir)
(setq xdir (getvar 'ucsxdir)
vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs)
)
(grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs)))
)
;;------------------
(if (setq
size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*)))
osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR")
osmode (reverse (sldectobin (getvar 'osmode) 1))
p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod)))
mode (cdr (assoc (if p
(vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x)))
(vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod)))
)
'(("_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)))
("_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))) ;X
("_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)))
("_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)))
)
)
)
)
(sldrawvecs (setq p (if p p pt)) mode size cl)
)
(if p p pt)
)
;;grread图元捕捉子函数-----(一级)------
;;name为移动的图元、选择集,pt为光标点
;;有捕捉点则返回捕捉点,无返回光标点
;;三领设计尘缘一生 QQ:15290049
(defun slosnappt (name pt / p0 p1 p2 newe ss size k)
(if (< (getvar "OSMODE") 16384) ;;打开捕捉
(progn
(if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏
(if (setq newe (car (nentselp pt)))
(progn
(setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX"))
p0 (e9pt newe 5)
ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size))
)
(if (or (null ss) (and ss (< (sslength ss) 2)))
(progn
(setq p1 (polar p0 pi size) p2 (polar p0 0 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
(setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size))
(entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d")))
)
)
)
)
(vl-catch-all-apply '(lambda () (setq pt (sl-osnappt pt))))
(if k (sl-sel-redrawsel name 1)) ;恢复显示
)
)
pt
)

;;grread图元捕捉函数-----(一级)------ 
;;name为移动的图元、选择集,pt为光标点 
;;有捕捉点则返回捕捉点,无返回光标点 
(defun sl-osnappt (pt / p mode osmod osmode size cl) 
  (defun sldectobin (n m / c f) ;;十进制转二进制 
    (setq f (if (< n 0) 1 0) n (abs n)) 
    (while (> (setq c (cons (rem n 2) c) n (* n 0.5)) 0)) 
    (while (< (length c) (1- m)) (setq c (cons 0 c))) 
    (cons f c) 
  ) 
  ;;------------------ 
  (defun sldrawvecs (pt vecs size cl / xdir) 
    (setq xdir (getvar 'ucsxdir) 
      vecs (mapcar '(lambda (x) (mapcar '(lambda (a) (mapcar '+ pt (mapcar '* (setq a (trans a 0 xdir) a (list (caddr a) (car a))) (list size size)))) x)) vecs) 
    ) 
    (grvecs (apply 'append (mapcar 'cons (mapcar (function (lambda (x) cl)) vecs) vecs))) 
  ) 
  ;;------------------ 
  (if (setq 
        size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")) 
        cl (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences *Acad*))) 
        osmod '("_NEA," "_QUA," "_END," "_MID," "_CEN," "_NOD," "_INT," "_INS," "_PER," "_TAN," "_APP," "_EXT," "_PAR") 
        osmode (reverse (sldectobin (getvar 'osmode) 1)) 
        p (osnap pt (apply 'strcat (mapcar '(lambda (x y) (if (zerop x) "" y)) osmode osmod))) 
        mode (cdr (assoc (if p 
                           (vl-some '(lambda (x) (if (equal p (cdr x) 1e-8) (car x))) 
                             (vl-remove 'nil (mapcar '(lambda (x y / p) (if (zerop x) nil (if (setq p (osnap pt y)) (cons y p)))) osmode osmod))) 
                         ) 
                    '(("_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))) 
                       ("_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))) ;X 
                       ("_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))) 
                       ("_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))) 
                     ) 
                  ) 
             ) 
      ) 
    (sldrawvecs (setq p (if p p pt)) mode size cl) 
  ) 
  (if p p pt) 
) 
;;grread图元捕捉子函数-----(一级)------ 
;;name为移动的图元、选择集,pt为光标点 
;;有捕捉点则返回捕捉点,无返回光标点 
;;三领设计 尘缘一生 QQ:15290049 
(defun slosnappt (name pt / p0 p1 p2 newe ss size k) 
  (if (< (getvar "OSMODE") 16384) ;;打开捕捉 
    (progn 
      (if name (progn (sl-sel-redrawsel name 2) (setq k t))) ;隐藏 
      (if (setq newe (car (nentselp pt))) 
        (progn 
          (setq size (* (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) (getvar "PICKBOX")) 
            p0 (e9pt newe 5) 
            ss (ssget "C" (polar p0 5pi4 size) (polar p0 pi4 size)) 
          ) 
          (if (or (null ss) (and ss (< (sslength ss) 2))) 
            (progn 
              (setq p1 (polar p0 pi size) p2 (polar p0 0 size)) 
              (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) 
              (setq p1 (polar p0 pi2 size) p2 (polar p0 3pi2 size)) 
              (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "f-i-n-d"))) 
            ) 
          ) 
        ) 
      ) 
      (vl-catch-all-apply '(lambda () (setq pt (sl-osnappt pt)))) 
      (if k (sl-sel-redrawsel name 1)) ;恢复显示 
    ) 
  ) 
  pt 
)

mercio · 发表于 2024-6-30 07:47

厉害，这么早就开始研究了

小菜123 · 发表于 2024-6-30 09:28

grread捕捉没有问题，都是精准的

尘缘一生 · 发表于 2024-6-30 09:45

小菜123 发表于 2024-6-30 09:28
grread捕捉没有问题，都是精准的

对，只是函数需要改进即可。

liuhe · 发表于 2024-6-30 14:23

小菜123 发表于 2024-6-30 09:28
grread捕捉没有问题，都是精准的

你这么牛笔，你封装一个函数，我试试学习。我用了大佬很多的封装的，不停地放大，最后都是不精准的。你能比leemac gul还厉害

小菜123 · 发表于 2024-6-30 14:50

小菜123 · 发表于 2024-6-30 15:03

顺路演示一下极轴追踪：

liuhe · 发表于 2024-6-30 16:11

小菜123 发表于 2024-6-30 14:50

你把图形放大到极限试试，顶点堆到一起试试，你看看还能不能精准

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

[经验] grread之历史开发经验剖析

本帖子中包含更多资源

评分

点评

本帖子中包含更多资源

点评

点评

本帖子中包含更多资源

本帖子中包含更多资源

点评

点评