同心圆或两直线加中心线

qxlonmsn · 发表于 2021-9-25 12:06:45

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 qxlonmsn 于 2021-9-25 12:12 编辑

(vl-load-com)
(setq somde (getvar "osmode"))
(setq secho (getvar "cmdecho"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(defun fy-LineFormat (obj lay lt sc col / qm40) ;线的格式
;图元名/obj对象图层线型圆0.8/线0.4 颜色
(vl-load-com)
(if (= (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj)))
(vla-put-layer obj lay)
(vla-put-Linetype obj lt)
(vla-put-Color obj col)
(setq qm40 (cdr (assoc 40 (tblsearch "ltype" lt))))
(if (and (/= qm40 0) (/= sc 0))
(vla-put-LinetypeScale obj (* (vla-get-Length obj) (/ sc qm40 (getvar "LTSCALE"))))
)
(vla-update obj)
(princ)
)
(defun ss->elst (ss / elst)
(setq i 0)
(repeat (sslength ss)
(setq elst (cons (ssname ss i) elst)
i (1+ i)
)
)
(reverse elst)
)
(defun elst->ss (elst / ss2)
(setq ss2 (ssadd))
(setq i 0)
(repeat (length elst)
(ssadd (nth i elst) ss2)
(setq i (1+ i))
)
ss2
)
(vl-load-com)
;;更新表中元素
;;(substn 5 3 (list 1 2 3 4 5 6 7))
;;(1 2 3 5 5 6 7)
;;(substn (list 5) 3 (list (list 1) (list 2) (list 3) (list 4) (list 5) (list 6) (list 7)))
;;((1) (2) (3) (5) (5) (6) (7))
(defun substn (a n l)
(if l
(if (= 0 n)
(cons a (cdr l))
(cons (car l) (substn a (1- n) (cdr l)))
)
)
)
(defun YJ (SS)
;;(setq SS (ssget '((0 . "circle"))))
(setq tol 0.01)
(setq retlst '())
(setq i 0)
(while (setq ent (ssname ss i))
(setq cenPt (cdr (assoc 10 (entget ent))))
(setq radious (cdr (assoc 40 (entget ent))))
(setq j 0)
(setq flag nil)
(repeat (length retlst)
(setq lst (car (nth j retlst)))
(if (and (equal (car lst) (car cenPt) tol)
(equal (cadr lst) (cadr cenPt) tol)
)
(progn
(setq entlst (cadr (nth j retlst)))
(setq entlst (cons (list ent radious) entlst))
(setq retlst (substn (list lst entlst) j retlst))
(setq flag T)
)
)
(setq j (1+ j))
)
(if (Not flag)
(progn
(setq
retlst (cons (list cenPt (list (list ent radious))) retlst)
)
)
)
(setq i (1+ i))
)
;;while
(setq i 0)
(repeat (length retlst)
(setq cenPt (car (nth i retlst)))
(setq lst (cadr (nth i retlst)))
(setq lst (vl-sort lst
'(lambda (s1 s2)
(> (cadr s1) (cadr s2))
)
)
)
(setq radious (cadr (nth 0 lst)))
(setq pt1 (polar cenPt 0 (* 1.2 radious)))
(setq pt2 (polar cenPt (* 0.5 pi) (* 1.2 radious)))
(setq pt3 (polar cenPt (* 1 pi) (* 1.2 radious)))
(setq pt4 (polar cenPt (* 1.5 pi) (* 1.2 radious)))
;;(Command "line" pt1 pt3 PT2 PT4 "")
(COMMAND "-LINETYPE" "S" "CENTER2" "")
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 pt1) (cons 11 pt3))
)
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 pt2) (cons 11 pt4))
)
(setq i (1+ i))
)
(setvar "osmode" somde)
(setvar "cmdecho" secho)
)
(defun C:YJ1 ()
(setq SSlst (ss->elst (ssget '((0 . "CIRCLE,LINE")))))
;;分离出圆和直线
(setq liness '())
(setq circless '())
(setq i 0)
(repeat (length sslst)
(setq entlst (entget (nth i sslst)))
(if (= (cdr (assoc 0 entlst)) "LINE")
(setq liness (cons (nth i sslst) liness))
)
(if (= (cdr (assoc 0 entlst)) "CIRCLE")
(setq circless (cons (nth i sslst) circless))
)
(setq i (1+ i))
)
;;处理圆的标注
(YJ (elst->ss circless))
;;判断直线个数
(if (= (length liness) 2)
(princ)
(exit)
)
(setq obj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument Obj))
(setq msp (vla-get-ModelSpace doc))
;;(setq en1 (car (entsel "\n请选择第一条直线")))
;;(setq en2 (car (entsel "\n请选择第二条直线")))
(setq en1 (nth 0 liness))
(setq en2 (nth 1 liness))
(setq p1 (vlax-curve-getstartpoint en1)
p2 (vlax-curve-getendpoint en1)
p3 (vlax-curve-getstartpoint en2)
p4 (vlax-curve-getendpoint en2)
p5 (inters p1 p2 p3 p4 nil)
)
(if (= nil p5)
(不平行 en1 en2)
(平行 en1 en2)
)
)
(defun 平行 (line1 line2)
;;(setq ee (entsel "\n请选择第一条直线:"))
;;两线平行时
(setq ename1 line1)
(redraw ename1 3)
(setq alist (entget ename1)
sp1 (cdr (assoc 10 alist))
ep1 (cdr (assoc 11 alist))
)
;;(setq ee (entsel "\n请选择第二条直线:"))
(setq ename2 line2)
(setq alist (entget ename2)
sp2 (cdr (assoc 10 alist))
ep2 (cdr (assoc 11 alist))
)
(setq flg (inters sp1 sp2 ep1 ep2))
(if (/= flg nil)
(setq dum sp2
sp2 ep2
ep2 dum
)
)
(setq p1x (car sp1)
p1y (cadr sp1)
p2x (car sp2)
p2y (cadr sp2)
mix (min p1x p2x)
mxx (max p1x p2x)
miy (min p1y p2y)
mxy (max p1y p2y)
pmx (+ mix (/ (- mxx mix) 2.0))
pmy (+ miy (/ (- mxy miy) 2.0))
smp (list pmx pmy)
)
(setq p1x (car ep1)
p1y (cadr ep1)
p2x (car ep2)
p2y (cadr ep2)
mix (min p1x p2x)
mxx (max p1x p2x)
miy (min p1y p2y)
mxy (max p1y p2y)
pmx (+ mix (/ (- mxx mix) 2.0))
pmy (+ miy (/ (- mxy miy) 2.0))
emp (list pmx pmy)
)
(COMMAND "-LINETYPE" "S" "CENTER2" "")
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 smp) (cons 11 emp))
)
(redraw)
;|
(while (setq ent (ssname ss 0))
(setq ss (ssdel ent ss))
(setq cenPt (cdr (assoc 10 (entget ent))))
(setq radious (cdr (assoc 40 (entget ent))))
(setq pt1 (polar cenPt 0 (* 1.2 radious)))
(setq pt2 (polar cenPt (* 0.5 pi) (* 1.2 radious)))
(setq pt3 (polar cenPt (* 1 pi) (* 1.2 radious)))
(setq pt4 (polar cenPt (* 1.5 pi) (* 1.2 radious)))
;;(Command "line" pt1 pt3 PT2 PT4 "")
(COMMAND "-LINETYPE" "S" "CENTER2" "")
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 pt1) (cons 11 pt3))
)
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 pt2) (cons 11 pt4))
)
)
;;while
|;
(PrinC)
)
(defun 不平行 (line1 line2)
(setq somde (getvar "osmode"))
(setq secho (getvar "cmdecho"))
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(vl-load-com)
;;两线不平行时
(setq obj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument Obj))
(setq msp (vla-get-ModelSpace doc))
;;(setq en1 (car (entsel "\n请选择第一条直线")))
;;(setq en2 (car (entsel "\n请选择第二条直线")))
(setq en1 line1)
(setq en2 line2)
(setq p1 (vlax-curve-getstartpoint en1)
p2 (vlax-curve-getendpoint en1)
p3 (vlax-curve-getstartpoint en2)
p4 (vlax-curve-getendpoint en2)
p5 (inters p1 p2 p3 p4 nil)
)
;;将p1和p3调整为靠近p5
(if (< (distance p5 p2) (distance p5 p1))
(progn
(setq tmpPt p1)
(setq p1 p2)
(setq p2 tmpPt)
)
)
(if (< (distance p5 p4) (distance p5 p3))
(progn
(setq tmpPt p3)
(setq p3 p4)
(setq p4 tmpPt)
)
)
(setq ang1 (angle p5 P2))
(setq ang2 (angle p5 P4))
(setq midang (- (max ang1 ang2)
(* 0.5 (- (max ang1 ang2) (min ang1 ang2)))
)
)
(setq p6 (polar p5 midang 1.0))
(setq p7 (inters p5 p6 P1 P3 nil))
;;注意这里若p5与p6重合，或者p1和p3重合时，由于线段距离为0，p7是求不出来的
(setq p8 (inters p5 p6 P2 P4 nil))
;;同上
(fy-LineFormat (makeline p7 p8) lay lt sc4 col)
(COMMAND "-LINETYPE" "S" "CENTER2" "")
(entmake
(list '(0 . "LINE") (cons 62 1) (cons 10 P7) (cons 11 P8))
)
(setvar "osmode" somde)
(setvar "cmdecho" secho)
)

lovezp · 发表于 2021-9-25 16:53:48

自定义函数竟然可以用中文命名

yuren008 · 发表于 2021-9-25 17:00:23

做个对论坛有益的人。

tzfcn · 发表于 2021-9-25 18:55:37

这个代码值得学习和分享。

Michael527 · 发表于 2021-9-25 19:31:09

谢谢楼主分享的源代码！

yangjian001 · 发表于 2021-9-26 08:51:17

做一个热心并受欢迎的人

qqqincccken · 发表于 2021-9-27 00:18:07

同心圆或两直线加中心线

lxs.cmy · 发表于 2021-9-27 09:27:33

正在找谢谢分享。。。。。。。

qxlonmsn · 发表于 2021-9-27 10:36:10

还是有点BUG的单个的圆或者单个的线要报错

yangjian001 · 发表于 2021-9-27 22:53:28

做一个热心并受欢迎的人

yangjian001 · 发表于 2021-9-28 08:36:13

做一个热心并受欢迎的人

13174545660 · 发表于 2023-12-20 08:25:11

好东西先收藏

seedjam · 发表于 2024-3-13 18:08:23

新手學習學習一下

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

[曲线] 同心圆或两直线加中心线

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。