腰形孔
;;; ===================================================;;; 功能：腰型孔;;; 作者：langjs 命令:yxk 日期:2021年12月4日
;;; ===================================================
(defun c:yxk (/ #err $orr chang code code1 color d dbl ent ent1 ent2 ent3 ent4 ent6 gr gr1 h i k kuan loop lst lx n name1 name2
name3 name4 nearpt nearpt2 old_lay osmo pp pt pt0 pt1 pt2 pt3 pt4 pt5 ptx pty r s ss stl 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)
(setvar "peditaccept" 1)(command ".UNDO" "BE")
(if (setq pt0 (getpoint "\n指定点:"))
(progn
(setq dbl (* 3.0 (getvar "DIMSCALE")))
(setq old_lay (getvar "clayer"))
(if (not (tblsearch "layer" "03中心线层"))
(vl-cmdf "_layer" "make" "03中心线层" "Color" 5 "" "L" "CENTER" "" ""))
(setvar "clayer" old_lay)
(setq ss (ssadd))
(entmake (list '(0 . "ARC") (cons 10 pt0) (cons 40 0) (cons 50 0.0) (cons 51 pi)))
(setq name1 (entlast) ent1 (entget name1)ss (ssadd name1 ss))
(entmake (list '(0 . "ARC") (cons 10 pt0) (cons 40 0) (cons 50 0.0) (cons 51 pi)))
(setq name2 (entlast)ent2 (entget name2) ss (ssadd name2 ss))
(entmake (list '(0 . "LINE") (cons 10 pt0) (cons 11 pt0)))
(setq name3 (entlast)ent3 (entget name3)ss (ssadd name3 ss))
(entmake (list '(0 . "LINE") (cons 10 pt0) (cons 11 pt0)))
(setq name4 (entlast) ent4 (entget name4)ss (ssadd name4 ss))
(setq loop t)
(princ "\n指定腰型孔宽度:")
(setq kuan nil chang nil )
(while loop
(setq gr (grread t 15 0)code (car gr)pt (cadr gr))
(cond
((= code 3) ; 鼠标左键
(redraw)
(setq loop nilkuan (* 2 d) chang (+ (distance pt0 pp) kuan)r (angle pt0 pp) )
(entmod (emod ent2 10 (polar pt0 r (- chang kuan))))
(setq pt1 (polar pt0 (+ r (* 0.5 pi)) d)pt2 (polar pt1 r (- chang kuan))
ent3 (emod ent3 10 pt1))
(entmod (emod ent3 11 pt2))
(setq pt1 (polar pt0 (- r (* 0.5 pi)) d) pt2 (polar pt1 r (- chang kuan))
ent4 (emod ent4 10 pt1))
(entmod (emod ent4 11 pt2))
(entmake (list '(0 . "line") (cons 8 "03中心线层") (cons 10 (polar pt0 r (* -1 (+ d dbl))))
(cons 11 (polar pt0 r (+(- chang kuan)d dbl)))) )
(setq pt1 (polar pt0 r (* 0.5 (- chang kuan))))
(entmake (list '(0 . "line") (cons 8 "03中心线层") (cons 10 (polar pt1 (+ r (* 0.5 pi)) (+ d dbl)))
(cons 11 (polar pt1 (+ r(* 0.5 pi) ) (* -1(+ d dbl) )))))
(command "PEDIT" "M" ss "" "J" 0.0 ""))
((= code 5) ; 鼠标移动
(redraw)
(setq pt (osnappt ss pt)r (angle pt0 pt) )
(cond
((or (>= r (* 1.75 pi)) (< r (* 0.25 pi))
(and(>= r (* 0.75 pi))(< r (* 1.25 pi))))
(if kuan(setq d (* 0.5 kuan)) (setq d (* 0.5 (abs (- (car pt) (car pt0))))))
(setq pp (list (car pt) (cadr pt0)))
(grvecs (list 5 pt0 pp))
(if (and (>= r (* 0.75 pi)) (< r (* 1.25 pi)))
(setq ent1 (emod ent1 51 (* 0.5 pi)) ent1 (emod ent1 50 (* 1.5 pi))
ent2 (emod ent2 51 (* 1.5 pi)) ent2 (emod ent2 50 (* 0.5 pi)))
(setq ent1 (emod ent1 50 (* 0.5 pi)) ent1 (emod ent1 51 (* 1.5 pi))
ent2 (emod ent2 50 (* 1.5 pi)) ent2 (emod ent2 51 (* 0.5 pi))))
(setq ent1 (emod ent1 40 d))
(entmod ent1)
(setq ent2 (emod ent2 40 d) ent2 (emod ent2 10 (list (car pt) (cadr pt0))))
(entmod ent2)
(setq ent3 (emod ent3 10 (list (car pt0) (+ (cadr pt0) d))) ent3 (emod ent3 11 (list (car pt) (+ (cadr pt0) d))))
(entmod ent3)
(setq ent4 (emod ent4 10 (list (car pt0) (- (cadr pt0) d))) ent4 (emod ent4 11 (list (car pt) (- (cadr pt0) d))))
(entmod ent4)
(entmod ent6)))
(cond
((or (and (>= r (* 1.25 pi)) (< r (* 1.75 pi)))
(and (>= r (* 0.25 pi)) (< r (* 0.75 pi)) ))
(if kuan (setq d (* 0.5 kuan)) (setq d (* 0.5 (abs (- (cadr pt) (cadr pt0))))))
(setq pp (list (car pt0) (cadr pt)))
(grvecs (list 5 pt0 pp))
(if (and (>= r (* 0.25 pi)) (< r (* 0.75 pi)))
(setq ent1 (emod ent1 50 (* 1 pi))ent1 (emod ent1 51 (* 0 pi))
ent2 (emod ent2 50 (* 0 pi))ent2 (emod ent2 51 (* 1 pi)))
(setq ent1 (emod ent1 50 (* 0 pi))ent1 (emod ent1 51 (* 1 pi))
ent2 (emod ent2 50 (* 1 pi))ent2 (emod ent2 51 (* 0 pi))))
(setq ent1 (emod ent1 40 d))
(entmod ent1)
(setq ent2 (emod ent2 40 d) ent2 (emod ent2 10 (list (car pt0) (cadr pt))))
(entmod ent2)
(setq ent3 (emod ent3 10 (list (+ (car pt0) d) (cadr pt0))) ent3 (emod ent3 11 (list (+ (car pt0) d) (cadr pt))))
(entmod ent3)
(setq ent4 (emod ent4 10 (list (- (car pt0) d) (cadr pt0))) ent4 (emod ent4 11 (list (- (car pt0) d) (cadr pt))))
(entmod ent4))))
((= code 2) ; 键盘输入
(if (member pt '(48 49 50 51 52 53 54 55 56 57))
(progn
(setq s (chr pt)) (princ (strcat s))
(while (progn
(setq gr1 (grread) code1 (car gr1)lx (cadr gr1))
(if (member lx '(46 48 49 50 51 52 53 54 55 56 57 8))
(progn (if (and(> (setq stl (strlen s))0 ) (= lx 8) ) ; 当有键盘输入按了退格
(progn (setq s (substr s 1 (1- stl))) ; 删除一个字
(if (null kuan) (princ (strcat "\n指定腰型孔宽度:" s)) (princ (strcat "\n指定腰型孔长度:" s)))))
(if (not (member lx '(8 13 32)))
(progn (setq s (strcat s (chr lx)))(princ (strcat (chr lx))))) ; 当有键盘输入按了退格
(if (= (strlen s) 0)
(if (null kuan) (princ "\n指定腰型孔宽度:")(princ "\n指定腰型孔长度:")))))
(and (not (member lx '(13 32))) (not (member code1 '(11 25))))))
(if (> (strlen s) 0)
(if (null kuan)
(progn (setq kuan (atof s)) (princ "\n指定腰型孔长度:"))
(progn
(redraw)
(setq chang (atof s)loop nilr (angle pt0 pp))
(entmod (emod ent2 10 (polar pt0 r (- chang kuan))))
(setq pt1 (polar pt0 (+ r (* 0.5 pi)) d) pt2 (polar pt1 r (- chang kuan))
ent3 (emod ent3 10 pt1))
(entmod (emod ent3 11 pt2))
(setq pt1 (polar pt0 (- r (* 0.5 pi)) d) pt2 (polar pt1 r (- chang kuan))
ent4 (emod ent4 10 pt1))
(entmod (emod ent4 11 pt2))
(entmake (list '(0 . "line") (cons 8 "03中心线层") (cons 10 (polar pt0 r (* -1 (+ d dbl))))
(cons 11 (polar pt0 r (+ (- chang kuan) d dbl)))))
(setq pt1 (polar pt0 r (* 0.5 (- chang kuan))))
(entmake (list '(0 . "line") (cons 8 "03中心线层") (cons 10 (polar pt1 (+ r (* 0.5 pi)) (+ d dbl)))
(cons 11 (polar pt1 (+ r (* 0.5 pi)) (* -1 (+ d dbl)))) ))
(command "PEDIT" "M" ss "" "J" 0.0 "") ) ))) ))
((member code '(11 25)) ; 鼠标右击
(redraw)
(setq loop nil)
(repeat (setq i (sslength ss)) (entdel (ssname ss (setq i (1- i))))))))))
(command ".UNDO" "E")
(setq *error* $orr)
(princ)
)
本帖最后由 尘缘一生 于 2021-12-7 20:45 编辑
借郎大师帖子，发下我用的，虽然这个对我专业不大用，但也考虑做了点工作，对于格式画线，请研究小菜版的智能中心线部分可也，这部分就是中线线的一部分fy_lineformat ，可以全部注销不用，我的是非动态，三点定位方式。
[*];;**************三点椭圆孔****************
[*](defun c:slot (/ w ang1 bp1 bp2 p1 p2 p3 p4 cp1 cp2 cp3 cp4 cp5 cp6 oldorh gj_oo)
[*](setq oldorh (getvar "ORTHOMODE"))
[*](setq gj_oo (getvar "osmode"))
[*](setvar "ORTHOMODE" 1) ;;正交打开
[*](setq bp1 (getpoint "\n 输入长圆孔第一个中心点:")
[*] bp2 (getpoint bp1 "\n 输入长圆孔第二个中心点:")
[*] bp3 (getpoint bp2 "\n 拉出长圆孔半个宽度点:")
[*] ang1 (angle bp1 bp2)
[*] w (distance bp2 bp3)
[*])
[*](setvar "cmdecho" 0)
[*](cykong bp1 bp2 w)
[*](setq w (/ (* 5 w) 3))
[*](setq cp1 (polar bp1 (+ ang1 pi2) w)
[*] cp2 (polar bp1 (+ ang1 3pi2) w)
[*] cp3 (polar bp2 (+ ang1 pi2) w)
[*] cp4 (polar bp2 (+ ang1 3pi2) w)
[*] cp5 (polar bp1 (+ ang1 pi) w)
[*] cp6 (polar bp2 ang1 w)
[*]);求得长圆孔中心轴线的六个关键点
[*];;------绘制长圆孔中心线------
[*](fy_lineformat (makeline cp1 cp2) "中心线" "CENTER" 0.4 6)
[*](fy_lineformat (makeline cp3 cp4) "中心线" "CENTER" 0.4 6)
[*](fy_lineformat (makeline cp5 cp6) "中心线" "CENTER" 0.4 6)
[*](setvar "osmode" gj_oo)
[*](setvar "ORTHOMODE" oldorh)
[*](princ)
[*])
[*];;画长圆孔---（一级）----------
[*](defun cykong (bp1 bp2 w / ang p1 p2 p3 p4)
[*](setq
[*] ang (angle bp1 bp2)
[*] p1 (polar bp1 (+ ang pi2) w)
[*] p2 (polar bp1 (+ ang 3pi2) w)
[*] p3 (polar bp2 (+ ang pi2) w)
[*] p4 (polar bp2 (+ ang 3pi2) w)
[*])
[*](entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(67 . 0) '(100 . "AcDbPolyline") '(90 . 5) '(70 . 1) (cons 10 p2) (cons 42 0)
[*] (cons 10 p4) (cons 42 1) (cons 10 p3)(cons 42 0) (cons 10 p1) (cons 42 1)(cons 10 p2) (cons 42 1) '(210 0.0 0.0 1.0))
[*])
[*])
[*];;--------格式画线----（一级)--------
[*];;参数：图元名 图层 线型 比例因子 颜色
[*](defun fy_lineformat (enam lay lt sc col / qm40 obj)
[*](cond
[*] ((= lay nil)
[*] (setq lay (dxf1 enam 8))
[*] )
[*] ((= lt nil)
[*] (setq lt (ss-linetype enam))
[*] )
[*] ((= col nil)
[*] (setq col (ss-getcolor enam))
[*] )
[*])
[*](setq obj (en2obj enam))
[*](vla-put-layer obj lay)
[*](vla-put-Linetype obj lt)
[*](vla-put-Color obj col)
[*](setq qm40 (dxf1 (tblsearch "ltype" lt) 40))
[*](if (and (/= qm40 0) (/= sc 0))
[*] (vla-put-LinetypeScale obj sc)
[*] (vla-put-LinetypeScale obj (* 0.01 (getvar "DIMLFAC")))
[*])
[*](vla-update obj)
[*])
[*];-------生成一条line----（一级)------------------------
[*];;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
[*](defun makeline (pt1 pt2)
[*](entmakex (list '(0 . "line") (cons 10 pt1) (cons 11 pt2)))
[*])
xiao88gang 发表于 2021-12-7 16:55
谢谢大师的分享，非常实用，怎么能把中心线去掉呢？
把所有类似(entmake (list '(0 . "line") (cons 8 "03中心线层") (cons 10 (polar pt1 (+ r (* 0.5 pi)) (+ d dbl)))的语句删除 大师新作，支持支持，感谢分享！！ 对钣金挺友好的，谢谢 大师出手果然牛批:D 感谢大师分享，好人万岁:lol 感谢大师分享！ 确实是好东西！ 能任意角度就好了 大师新作，学以致敬！ 感谢大师分享！