求输入tt，提示选择圆，选择某一图层的圆后，提示选择某一图层的线，确认后选中所
本帖最后由 664571221 于 2023-12-8 14:24 编辑求输入tt，提示选择圆，选择某一图层的圆后，提示选择某一图层的线，确认后选中所和这个圆相交的这个图层的线
664571221 发表于 2023-12-9 09:25
小韩代码
(defun c:tt(/ fx-pline fx-polygonout i lst1 s1 s2 sa ss ss1 ss2 ssa ssunion tc1 tc2 xyp-ss2list)
(defun xyp-DXF (code ename / ent lst a)
(if (= (type code) 'LIST)
(progn
(setq ent (entget ename)
lst '()
)
(foreach a code
(setq lst (cons (list a (cdr (assoc a ent))) lst))
)
(reverse lst)
)
(if (= code -3)
(cdr (assoc code (entget ename '("*"))))
(cdr (assoc code (entget ename)))
))
)
(defun fx-polygonout(s1 n dist / i jd p1 pt ptn r x y)
(setq
pt (xyp-dxf 10 s1)
ang (/ (* 2 pi) n)
r (+ (xyp-dxf 40 s1) dist)
r (/ r (cos (/ ang 2)))
i 0
ptn (list (list (+ (car pt) r) (cadr pt) 0.0))
)
(repeat
(- n 1)
(setq
i (1+ i)
jd (* i ang)
y (* r (sin jd))
x (* r (cos jd))
p1 (xyp-Pt2XY pt x y)
ptn (append (list p1) ptn)
)
)
ptn
)
(defun fx-pline(ptn mode / i)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(command "pline")
(apply 'commandptn)
(if (= mode t) (command "c") (command ""))
(setvar "osmode" osm)
)
(defun SsUnion (ss1 ss2)
(command "select" ss1 ss2"")
(ssget "p")
)
(defun xyp-ss2list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(command "-VIEW" "s" "起始视图")
(setq
s1 (car (entsel "\n选择样板圆"))
tc1 (cdr (assoc 8 (entget s1)))
s2 (car (entsel "\n选择样板线"))
tc2 (cdr (assoc 8 (entget s2)))
)
(command "zoom" "e")
(setq
ss1 (ssget "x" (list (cons 0 "circle") (cons 8 tc1)))
lst1 (xyp-ss2list ss1)
ss (ssadd)
i -1
)
(while (setq sa (nth (setq i (1+ i)) lst1))
(setq
ssa (ssget "f" (fx-polygonout sa 90 0.5) (list (cons 0 "*line*") (cons 8 tc2)))
ss (SsUnion ssa ss)
)
)
(command "-VIEW" "r" "起始视图")
(sssetfirst nil ss)
)
(defun c:tt1(/ fx-pline fx-polygonout i lay lst1 lsta osm r s0 s0-ss s1 s2 sa ss ss1 ss2 ssa ssunion tc1 tc2 xyp-9pt xyp-ss2list)
(defun xyp-DXF (code ename / ent lst a)
(if (= (type code) 'LIST)
(progn
(setq ent (entget ename)
lst '()
)
(foreach a code
(setq lst (cons (list a (cdr (assoc a ent))) lst))
)
(reverse lst)
)
(if (= code -3)
(cdr (assoc code (entget ename '("*"))))
(cdr (assoc code (entget ename)))
))
)
(defun fx-polygonout(s1 n dist / i jd p1 pt ptn r x y)
(setq
pt (xyp-dxf 10 s1)
ang (/ (* 2 pi) n)
r (+ (xyp-dxf 40 s1) dist)
r (/ r (cos (/ ang 2)))
i 0
ptn (list (list (+ (car pt) r) (cadr pt) 0.0))
)
(repeat
(- n 1)
(setq
i (1+ i)
jd (* i ang)
y (* r (sin jd))
x (* r (cos jd))
p1 (xyp-Pt2XY pt x y)
ptn (append (list p1) ptn)
)
)
ptn
)
(defun xyp-Pt2XY(pt x y)
(setq pt (list (+ (car pt) x) (+ (cadr pt) y)))
)
(defun xyp-SselEntnext (s0 / ss)
(setq ss (ssadd))
(while (setq s0 (entnext s0))
(setq ss (ssadd s0 ss))
)
(if (/= (sslength ss) 0)
ss
)
)
(defun xyp-9Pt (ss site / MinPT MaxPT p1 p9 p5 p3 p7 p2 p4 p6 p8)
(defun mid (p1 p2)(mapcar '(lambda (x) (* x 0.5)) (mapcar '+ p1 p2)))
(defun zdwkgj(ss / i m n o)
(if (= (type ss) 'ENAME) (setq ssa nil ssa (ssadd) ssa (ssadd ss ssa) ss ssa))
(repeat (setq i (sslength ss))
(if
(and
(setq o (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
)
)
)
(setq
m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
'(min max)
(list m n)
)
)
)
(setq
p1 (car (zdwkgj ss))
p9 (cadr (zdwkgj ss))
p5 (mid p1 p9)
p3 (if (< (car p9) (car p1))
(list (car p1) (cadr p9) (caddr p1))
(list (car p9) (cadr p1) (caddr p1))
)
p7 (if (< (car p9) (car p1))
(list (car p9) (cadr p1) (caddr p9))
(list (car p1) (cadr p9) (caddr p9))
)
p2 (mid p1 p3)
p4 (mid p1 p7)
p6 (mid p3 p9)
p8 (mid p7 p9)
)
(nth (- site 1) (list p1 p2 p3 p4 p5 p6 p7 p8 p9))
)
(defun fx-pline(ptn mode / i)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(command "pline")
(apply 'commandptn)
(if (= mode t) (command "c") (command ""))
(setvar "osmode" osm)
)
(defun SsUnion (ss1 ss2)
(command "select" ss1 ss2"")
(ssget "p")
)
(defun xyp-ss2list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(setq lay (getvar "CLAYER") osm (getvar "osmode"))
(setvar "osmode" 0)
(command "-VIEW" "s" "起始视图")
(setq
s1 (car (entsel "\n选择样板圆块"))
tc1 (cdr (assoc 8 (entget s1)))
r (distance (xyp-9pt s1 4) (xyp-9pt s1 5))
s2 (car (entsel "\n选择样板线"))
tc2 (cdr (assoc 8 (entget s2)))
)
(command "zoom" "e")
(setq
lsta (xyp-ss2list (ssget "x" (list (cons 0 "INSERT") (cons 8 tc1))))
)
(setvar "CLAYER" tc1)
(setq s0 (entlast))
(mapcar '(lambda (x) (vl-cmdf "circle" (xyp-9pt x 5) r)) lsta)
(setq
s0-ss (xyp-SselEntnext s0)
ss1 (ssget "x" (list (cons 0 "circle") (cons 8 tc1)))
lst1 (xyp-ss2list ss1)
ss (ssadd)
i -1
)
(while (setq sa (nth (setq i (1+ i)) lst1))
(setq
ssa (ssget "f" (fx-polygonout sa 90 0.5) (list (cons 0 "*line*") (cons 8 tc2)))
ss (SsUnion ssa ss)
)
)
(setvar "CLAYER" lay)
(setvar "osmode" osm)
(vl-cmdf "erase" s0-ss "")
(command "-VIEW" "r" "起始视图")
(sssetfirst nil ss)
)
本帖最后由 韩飞翔 于 2023-12-9 09:54 编辑
如果是圆则按照这个代码
本帖最后由 韩飞翔 于 2023-12-8 16:27 编辑
看下条 本帖最后由 韩飞翔 于 2023-12-9 09:55 编辑
如果圆
是块，看这个代码 波总代码(defun c:tt (/ b bb e ee i k la p p1 p3 pt1 pt2 pt3 pt4 r s s1 ss)
(if (and ;(setq la "PIPE-污水")
(setq e (ssget ":E:S" '((0 . "LWP*"))))
(setq la (cdr (assoc 8 (entget (ssname e 0)))))
(setq s (ssget '((0 . "INS*"))))
(setq i -1)
)
(progn
(setq ss (ssadd))
(while (setq e (ssname s (setq i (1+ i))))
(vla-Explode (vlax-ename->vla-object e))
(if (and (setq e (entlast))
(setq ee (entget e))
(= "CIRCLE" (cdr (assoc 0 ee)))
(setq p (cdr (assoc 10 ee))
r (+ 1e-3 (cdr (assoc 40 ee)))
pt1 (mapcar '- p (list r r))
pt2 (mapcar '+ p (list (- r) r))
pt3 (mapcar '+ p (list r r))
pt4 (mapcar '+ p (listr (- r)))
p1 (mapcar '- pt1 (list r r))
p3 (mapcar '+ pt3 (list r r))
)
(setq e (vlax-ename->vla-object e))
)
(progn
(vla-ZoomWindow (vlax-get-acad-object) (vlax-3D-point p1) (vlax-3D-point p3))
(if (setq s1 (ssget "CP" (list pt1 pt2 pt3 pt4 pt1) (list '(0 . "LWPOLY*")(cons 8 la))))
(progn
(setq k -1)
(while (setq b (ssname s1 (setq k (1+ k))))
(if (and (not (ssmemb b ss))
(setq bb (vlax-ename->vla-object b))
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-IntersectWith (list e bb acExtendNone))
)
)
)
(ssadd b ss)
)
)
)
)
(vla-Delete e)
(if (<= 1 (sslength ss))
(sssetfirst nil ss)
)
)
)
)
)
)
) 本帖最后由 664571221 于 2023-12-9 09:54 编辑
664571221 发表于 2023-12-9 09:22
波总代码(defun c:tt (/ b bb e ee i k la p p1 p3 pt1 pt2 pt3 pt4 r s s1 ss)
(if (and ;(setq...
小韩代码看最后的
页:
[1]