grread捕捉子函数(支持捕捉垂足,圆和圆弧的圆心,切线,支持正交)

langjs

grread对垂足,圆和圆弧的圆心以及切线点的捕捉一直是不太友好
以前发布一版grread捕捉子函数，现在更新一下
可以支持捕捉垂足,圆和圆弧的圆心,切线点了,也支持正交切换

样例中给出了一个简单的使用方法，支持键盘输入数值
有需要grread捕捉的可以拿去用用

;;; grread捕捉子函数(支持捕捉垂足,圆和圆弧的圆心,切线,支持正交)
;;; ss为移动的图元名或选择集，pt为光标点
;;; 返回值：如果有捕捉点则返回捕捉点，无则返回光标点
(defun osnappt (ss pt / color d h i k lst nearpt nearpt2 osmo pt1 pt10 pt11 pt12 pt13 pt2 pt3 pt4 pt5 pt6 pt7 pt8 ptc1 ptc2 ptc3 ptc4
                   ptc5 ptc6 ptc7 ptc8 ptx pty ss1 x
               )                       ; 捕捉子函数:ss为移动的图元名或选择集，pt为光标点;$pt001有值则捕捉垂足和切线
  (if (= (type ss) 'ename)
    (entdel ss)
  )
  (if (= (type ss) 'pickset)
    (repeat (setq i (sslength ss))
      (entdel (ssname ss (setq i (1- i))))
    )
  )
  (redraw)
  (if $pt001
    (progn
      (setvar "lastpoint" $pt001)
      (if (= (getvar "ORTHOMODE") 1)   ; 区分象限
        (cond
          ((or
             (<= (* 0.25 pi) (angle $pt001 pt) (* 0.75 pi))
             (<= (* 1.25 pi) (angle $pt001 pt) (* 1.75 pi))
           )
            (setq pt (list (car $pt001) (+ (cadr $pt001) (* (distance $pt001 pt) (sin (angle $pt001 pt))))))
          )
          (t
            (setq pt (list (+ (car $pt001) (* (distance $pt001 pt) (cos (angle $pt001 pt)))) (cadr $pt001)))
          )
        )
      )
    )
  )
  (if (< (getvar "osmode") 16384)
    (progn
      (setq color (vla-get-autosnapmarkercolor (vla-get-drafting (vla-get-preferences (vlax-get-acad-object))))
            h (/ (getvar "viewsize") (cadr (getvar "screensize")))
            d (getvar "pickbox")
            lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
            k (* 1.5 d h)
      )
      (if (setq nearpt (osnap pt "_NEA")) ; 接近
        (progn
          (setq osmo 1)
        )
      )
      (if (and
            (setq nearpt2 (osnap pt "_END,_NOD,_INS,_EXT")) ; 端点
            (equal nearpt nearpt2 k)
          )
        (setq osmo 2
              nearpt nearpt2
        )
      )
      (if (and
            (setq nearpt2 (osnap pt "_MID")) ; 中点
            (equal nearpt nearpt2 k)
          )
        (setq osmo 3
              nearpt nearpt2
        )
      )
      (if (and
            (setq nearpt2 (osnap pt "_INT")) ; 交点
            (equal nearpt nearpt2 k)
          )
        (setq osmo 4
              nearpt nearpt2
        )
      )
      (if (and
            $pt001
            (setq nearpt2 (osnap pt "_PER")) ; 垂足
            (equal nearpt nearpt2 k)
          )
        (setq osmo 5
              nearpt nearpt2
        )
      )
      (if (and
            (setq nearpt2 (osnap pt "_QUA")) ; 象限点
            (equal nearpt nearpt2 k)
          )
        (setq osmo 6
              nearpt nearpt2
        )
      )
      (if (and
            $pt001
            (setq nearpt2 (osnap pt "_TAN")) ; 切点
            (equal nearpt nearpt2 k)
          )
        (setq osmo 7
              nearpt nearpt2
        )
      )
    )
  )
  (if nearpt
    (progn
      (setq ptx (car nearpt)
            pty (cadr nearpt)
      )
      (foreach x lst
        (setq pt1 (list (- ptx x) (- pty x))
              pt2 (list (+ ptx x) (- pty x))
              pt3 (list (+ ptx x) (+ pty x))
              pt4 (list (- ptx x) (+ pty x))
              pt5 (list ptx (+ pty x))
              pt6 (list ptx (- pty x))
              pt7 (list (- ptx x) pty)
              pt8 (list (+ ptx x) pty)
              pt10 (list (- ptx (* 0.7 x)) (+ pty (* 0.7 x)))
              pt11 (list (- ptx (* 0.7 x)) (- pty (* 0.7 x)))
              pt12 (list (+ ptx (* 0.7 x)) (- pty (* 0.7 x)))
              pt13 (list (+ ptx (* 0.7 x)) (+ pty (* 0.7 x)))
        )
        (cond
          ((= osmo 1)                       ; 接近画俩三角
            (grvecs (list color pt1 pt2 pt2 pt4 pt3 pt4 pt3 pt1))
          )
          ((= osmo 2)                       ; 端点画正方形
            (grvecs (list color pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1))
          )
          ((= osmo 3)                       ; 中点画三角
            (grvecs (list color pt1 pt2 pt2 pt5 pt5 pt1))
          )
          ((= osmo 4)                       ; 交点画交叉
            (grvecs (list color pt1 pt3 pt2 pt4))
          )
          ((= osmo 5)                       ; 垂足画垂足l
            (grvecs (list color pt1 pt2 pt1 pt4))
          )
          ((= osmo 6)                       ; 象限点画菱形
            (grvecs (list color pt5 pt7 pt7 pt6 pt6 pt8 pt8 pt5))
          )
          ((= osmo 7)                       ; 切点画圆加横
            (grvecs (list color pt5 pt10 pt10 pt7 pt7 pt11 pt11 pt6 pt6 pt12 pt12 pt8 pt8 pt13 pt13 pt5 pt3 pt4))
          )
        )
      )
      (if (setq ss1 (ssget "C" nearpt nearpt '((0 . "CIRCLE,ARC")))) ; 如果捕捉到圆或者圆弧，则提取圆心坐标和半径
        (setq $yan (list (cdr (assoc 10 (entget (ssname ss1 0)))) (cdr (assoc 40 (entget (ssname ss1 0))))))
      )
      (setq pt nearpt)
    )
  )
  (if $yan                               ; $yan为全局变量，用于判断是否找到圆
    (if (<= (distance (car $yan) pt) (+ (cadr $yan) k))
      (progn
        (setq ptc1 (list (car (car $yan)) (+ (cadr (car $yan)) k))
              ptc2 (list (car (car $yan)) (- (cadr (car $yan)) k))
              ptc3 (list (- (car (car $yan)) k) (cadr (car $yan)))
              ptc4 (list (+ (car (car $yan)) k) (cadr (car $yan)))
              ptc5 (list (- (car (car $yan)) (* 0.7 k)) (+ (cadr (car $yan)) (* 0.7 k)))
              ptc6 (list (- (car (car $yan)) (* 0.7 k)) (- (cadr (car $yan)) (* 0.7 k)))
              ptc7 (list (+ (car (car $yan)) (* 0.7 k)) (- (cadr (car $yan)) (* 0.7 k)))
              ptc8 (list (+ (car (car $yan)) (* 0.7 k)) (+ (cadr (car $yan)) (* 0.7 k)))
        )
        (grvecs (list color ptc1 ptc2 ptc3 ptc4)) ; 画圆心十字
        (if (<= (distance (car $yan) pt) k) ; 距离接近圆心时，在圆心处画圆
          (progn
            (redraw)
            (grvecs (list color ptc1 ptc5 ptc5 ptc3 ptc3 ptc6 ptc6 ptc2 ptc2 ptc7 ptc7 ptc4 ptc4 ptc8 ptc8 ptc1))
            (setq pt (car $yan))
          )
        )
      )
      (setq $yan nil)
    )
  )
  (if (= (type ss) 'ename)
    (entdel ss)
  )
  (if (= (type ss) 'pickset)
    (repeat (setq i (sslength ss))
      (entdel (ssname ss (setq i (1- i))))
    )
  )
  pt
)
;;; 示例:动态画直线
;;; 支持捕捉，支持键盘输入数值，支持f8正交切换
(defun c:aa (/ $pt001 code code1 dis ent gr gr1 loop loop1 lx name pt pt0 r s stl)
  (if (setq pt0 (getpoint "\n指定第一个点:"))
    (progn
      (entmake (list '(0 . "LINE") (cons 10 pt0) (cons 11 pt0)))
      (setq name (entlast))
      (setq ent (entget name))
      (setq $pt001 pt0)                       ; $pt001为初始点坐标，有值时候，捕捉时候能捕捉过这个点的垂足和切线。
      (setq loop t)                       ; $pt001无值则不捕捉垂足和切线。
      (while loop
        (setq gr (grread t 15 0)
              code (car gr)
              pt (cadr gr)
        )
        (cond
          ((= code 2)                       ; 键盘输入
            (if (= pt 15)               ; f8切换正交
              (if (= (getvar "ORTHOMODE") 1)
                (progn
                  (setvar "ORTHOMODE" 0)
                  (princ "<正交 关>")
                )
                (progn
                  (setvar "ORTHOMODE" 1)
                  (princ "<正交 开>")
                )
              )
            )
            (if (member pt '(48 49 50 51 52 53 54 55 56 57)) ; 键盘输入数字
              (progn
                (setq s (chr pt))
                (princ (strcat s))
                (setq loop1 t)
                (while loop1
                  (setq gr1 (grread)
                        code1 (car gr1)
                        lx (cadr gr1)
                  )
                  (cond
                    ((= code1 2)
                      (cond
                        ((member lx '(13)) ; 键盘输入数字回车；大于0时候退出所有循环更新图元
                          (setq loop1 nil)
                          (if (> (strlen s) 0)
                            (progn
                              (setq loop nil)
                              (setq dis (atof s)) ; dis为键盘输入的数值
                              (entmod (subst
                                        (cons 10 (polar pt0 r dis))
                                        (assoc 10 ent)
                                        ent
                                      )
                              )
                            )
                          )
                        )
                        ((member lx '(46 48 49 50 51 52 53 54 55 56 57 8))
                          (if (and
                                (> (setq stl (strlen s))
                                   0
                                )
                                (= lx 8)
                              )               ; 当键盘输入按了退格; 删除一个字符并换行
                            (progn
                              (setq s (substr s 1 (1- stl)))
                              (princ (strcat "\n指定下一点,或输入长度:<" (rtos dis 2 2) ">" s))
                            )
                          )
                          (if (not (member lx '(8 13 32)))
                            (progn
                              (setq s (strcat s (chr lx)))
                              (princ (strcat (chr lx)))
                            )
                          )
                          (if (= (strlen s) 0) ; 当键盘输入退格为0时候退出键盘输入循环
                            (setq loop1 nil)
                          )
                        )
                      )
                    )
                    ((member code1 '(3)) ; 键盘输入鼠标左击退出键盘输入循环
                      (setq loop1 nil)
                    )
                    ((member code1 '(11 25)) ; 鼠标右击大于0时候退出所有循环更新图元
                      (setq loop1 nil)
                      (if (> (strlen s) 0)
                        (progn
                          (setq loop nil)
                          (setq dis (atof s))
                          (entmod (subst
                                    (cons 10 (polar pt0 r dis))
                                    (assoc 10 ent)
                                    ent
                                  )
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
          )
          ((= code 3)                       ; 鼠标左键
            (redraw)
            (setq loop nil)
            (setq pt (osnappt name pt))        ; 调用捕捉子函数
            (entmod (subst
                      (cons 10 pt)
                      (assoc 10 ent)
                      ent
                    )
            )
          )
          ((= code 5)                       ; 鼠标移动
            (setq pt (osnappt name pt))
            (setq r (angle pt0 pt))
            (setq dis (distance pt0 pt)) ; 调用捕捉子函数
            (princ (strcat "\n指定下一点,或输入长度:<" (rtos dis 2 2) ">"))
            (entmod (subst
                      (cons 10 pt)
                      (assoc 10 ent)
                      ent
                    )
            )
          )
          ((member code '(11 25))      ; 鼠标右击
            (redraw)
            (entdel name)
            (setq loop nil)
          )
        )
      )
    )
  )
  (princ)
)

langjs

yanshengjiang 发表于 2025-10-19 10:23
这类函数一直没怎么看懂。不知道中途能不能调用自带的捕捉设置框。

Grread函数最大的作用是拖动鼠标时候返回光标点的坐标，键盘输入不同按键返回特定数值，按鼠标左键和右键也返回不同特定值，其它都要按返回的值判断执行不同的程序。编写具有拖动动态效果的程序要用到这个函数。

阿猪蛋

下来看看                     

edsion24

下来看看                     

hncjddd

膜拜大师，给力

lxl304712346

牛皮！！！！！！！！！膜拜大神

yanshengjiang

这类函数一直没怎么看懂。不知道中途能不能调用自带的捕捉设置框。

forestgxc

一直没解决这个问题，下下来研究一下

q530496591

超厉害的函数。只可惜对grread函数研究的少，但是收藏了。以后有功能用到再拿出来。666

ocoipw

学习了，谢谢！

gf123

学习学习666！！！