带grread捕捉绘制螺纹孔程序

langjs

有很多人觉得 grread加捕捉挺难，以前研究过大神的程序，自己整了个grread带捕捉的子函数，感觉挺好用，需要grread带捕捉功能直接调用子函数。下面是我最新编的画螺纹孔程序用到了，发出来仅供参考。




;;; ===================================================
;;; 功能：螺纹孔程序
;;; 作者：langjs      命令:lwk     日期:2022年02月14日
;;; ===================================================
(defun c:lwk (/ #err $orr bl code color d dbl dd ent ent1 ent2 ent3 ent4 gr h i k loop lst n name1 name2 name3 name4 nearpt
                nearpt2 old_lay osmo p pt pt1 pt2 pt3 pt4 pt5 ptx pty ss x
             )
  (defun osnappt (ss pt / color d h i k lst nearpt nearpt2 osmo pt1 pt2 pt3 pt4 pt5 ptx pty x) ; grread捕捉子函数
    (if (= (type ss) 'ename)
      (entdel ss)
    )
    (if (= (type ss) 'pickset)
      (repeat (setq i (sslength ss))
        (entdel (ssname ss (setq i (1- i))))
      )
    )
    (redraw)
    (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 "_END,_CEN,_NOD,_QUA,_INS,_TAN,_EXT"))
          (setq osmo 1)
        )
        (if (and
              (setq nearpt2 (osnap pt "_NEA"))
              (not (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 (= (type ss) 'ename)
      (entdel ss)
    )
    (if (= (type ss) 'pickset)
      (repeat (setq i (sslength ss))
        (entdel (ssname ss (setq i (1- i))))
      )
    )
    (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))
          )
          (cond
            ((= osmo 1)                       ; 正方形
              (grvecs (list color pt1 pt2 pt2 pt3 pt3 pt4 pt4 pt1))
            )
            ((= osmo 2)                       ; 俩三角
              (grvecs (list color pt1 pt2 pt2 pt4 pt3 pt4 pt3 pt1))
            )
            ((= osmo 3)                       ; 三角
              (grvecs (list color pt1 pt2 pt2 pt5 pt5 pt1))
            )
            ((= osmo 4)                       ; 交叉
              (grvecs (list color pt1 pt3 color pt2 pt4))
            )
          )
        )
        (setq pt nearpt)
      )
    )
    pt
  )
  (defun emod (ent i n)                       ; 更新图元函数
    (subst
      (cons i n)
      (assoc i ent)
      ent
    )
  )
  (defun #err (s / i)                       ; 出错处理子函数
    (redraw)
    (if ss
      (repeat (setq i (sslength ss))
        (entdel (ssname ss (setq i (1- i))))
      )
    )
    (command ".UNDO" "E")
    (setq *error* $orr)
  )
  (setq $orr *error*)
  (setq *error* #err)
  (setvar "cmdecho" 0)
  (command ".UNDO" "BE")
  (setq old_lay (getvar "clayer"))
  (if (not (tblsearch "layer" "02细实线层"))
    (vl-cmdf "_layer" "make" "02细实线层" "Color" 3 "" "L" "Continuous" "" "")
  )
  (if (not (tblsearch "layer" "03中心线层"))
    (vl-cmdf "_layer" "make" "03中心线层" "Color" 5 "" "L" "CENTER" "" "")
  )
  (setvar "clayer" old_lay)
  (if (null d)
    (setq d (getreal "\n螺纹孔尺寸M："))
  )
  (princ (strcat "\n螺纹孔尺寸：<M" (rtos d 2 2) ">"))
  (setq lst (list '(1.2 0.25) '(1.4 0.3) '(1.8 0.35) '(2 0.4) '(2.5 0.45) '(3 0.5) '(3.5 0.6) '(4 0.7) '(4.5 0.75) '
                  (5.5 0.8) '(6 1) '(9 1.25) '(11 1.5) '(12 1.75) '(16 2) '(22 2.5) '(27 3) '(33 3.5) '(39 4) '(45 4.5) '
                  (52 5) '(60 5.5) '(149 6) '(1000000 8)
            )
  )
  (foreach x lst
    (if (and
          (null p)
          (<= d (car x))
        )
      (setq p (cadr x))
    )
  )
  (if (<= d 1.2)
    (setq p (* 0.2 d))
  )
  (setq dbl (getvar "DIMSCALE"))
  (if (< d (* 3 dbl))
    (setq dd d)
    (setq dd (+ (* 0.5 d) (* 3 dbl)))
  )
  (if (< (setq n (* 2 dd))
         (* 2 dbl)
      )
    (setq bl (/ n (cdr (assoc 40 (tblsearch "ltype" "CENTER"))) (getvar "LTSCALE")))
    (setq bl (/ (* 2 dbl) (cdr (assoc 40 (tblsearch "ltype" "CENTER"))) (getvar "LTSCALE")))
  )
  (setq ss (ssadd))
  (entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 '(0.0 0.0)) (cons 11 '(0.0 0.0))))
  (setq name1 (entlast)
        ent1 (entget name1)
        ss (ssadd)
        ss (ssadd name1 ss)
  )
  (entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 '(0.0 0.0)) (cons 11 '(0.0 0.0))))
  (setq name2 (entlast)
        ss (ssadd name2 ss)
        ent2 (entget name2)
  )
  (entmake (list '(0 . "ARC") (cons 8 "02细实线层") (cons 10 '(0.0 0.0)) (cons 40 (* 0.5 d)) (cons 50 (* 1.5 pi))
                 (cons 51 pi)
           )
  )
  (setq name3 (entlast)
        ent3 (entget name3)
        ss (ssadd name3 ss)
  )
  (entmake (list '(0 . "CIRCLE") (cons 10 '(0.0 0.0)) (cons 40 (* 0.5 (- d p)))))
  (setq name4 (entlast)
        ent4 (entget name4)
        ss (ssadd name4 ss)
  )
  (setq loop t)
  (while loop
    (setq gr (grread t 15 1)
          code (car gr)
          pt (cadr gr)
    )
    (cond
      ((= code 5)                       ; 鼠标移动
        (redraw)
        (setq pt (osnappt ss pt))      ; 取得grread捕捉点

       
        (setq ent1 (emod ent1 10 (polar pt 0.0 dd)))
        (entmod (emod ent1 11 (polar pt pi dd)))
        (setq ent2 (emod ent2 10 (polar pt (* 0.5 pi) dd)))
        (entmod (emod ent2 11 (polar pt (* -0.5 pi) dd)))
        (entmod (emod ent3 10 pt))
        (entmod (emod ent4 10 pt))
      )
      ((= code 3)                       ; 鼠标左键
        (redraw)
(setq pt (osnappt ss pt))
        (entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 (polar pt 0.0 dd)) (cons 11 (polar pt pi dd))))
        (entmake (list '(0 . "LINE") (cons 8 "03中心线层") (cons 48 bl) (cons 10 (polar pt (* 0.5 pi) dd)) (cons 11
                                                                                                                 (polar pt
                                                                                                                        (* -0.5
                                                                                                                           pi
                                                                                                                        ) dd
                                                                                                                 )
                                                                                                           )
                 )
        )
        (entmake (list '(0 . "ARC") (cons 8 "02细实线层") (cons 10 pt) (cons 40 (* 0.5 d)) (cons 50 (* 1.5 pi)) (cons 51 pi)))
        (entmake (list '(0 . "CIRCLE") (cons 10 pt) (cons 40 (* 0.5 (- d p)))))
      )
      ((member code '(11 25))               ; 鼠标右击
        (redraw)
        (setq loop nil)
        (repeat (setq i (sslength ss))
          (entdel (ssname ss (setq i (1- i))))
        )
      )
    )
  )
  (setq *error* $orr)
  (command ".UNDO" "E")
  (princ)
)

paulpipi

感谢分享，牛牛牛

liuhe

((= code 3)(setq loop nil) )  这样就行了  不需要再生成，然后删除原来的。速度还会更快

蓦然语嫣

命令: LWK
螺纹孔尺寸 M：30
螺纹孔尺寸：<M30>参数太少
这是怎么回事

yoyoho

谢谢! langjs 分享程序!!!

yoyoho

谢谢! langjs 分享程序!!!

gaics

学习一下grread函数！

htlaser

刚测试   捕捉不到端点

Wanda

感谢分享精神

mokson

我对 grread 命令没有什么认识，需要好好学习。

20060510412

请问lang大师，图中元素数量比较多的时候，捕捉子程序的速度怎么样啊？

GNJLISP

捕捉端点会跑偏