如何选择圆后自动删除与圆相交的水平线
如何选择圆后，自动删除与圆相交的水平线相交的非水平线和不相交的线均不删除
谢谢
(defun c:delhoriz (/ ent cir obj circle-data line-obj line-data pt1 pt2
min-x max-x min-y max-y line-y
circle-center circle-radius dist)
; 设置系统变量
(setvar "osmode" 0)
(setvar "cmdecho" 0)
; 提示用户选择一个圆
(princ "\n请选择一个圆: ")
(setq ent (entsel)
cir (car ent)
obj (vlax-ename->vla-object cir))
; 检查选择的是否为圆
(if (/= (vla-get-objectname obj) "AcDbCircle")
(progn
(princ "\n选择的不是圆!")
(exit)
)
)
; 获取圆的参数
(setq circle-center (vla-get-center obj)
circle-radius (vla-get-radius obj))
; 提示操作信息
(princ "\n正在处理与圆相交的水平线...")
; 遍历所有直线
(setq line-obj (vla-get-activedocument (vlax-get-acad-object))
line-obj (vla-get-modelspace line-obj)
line-obj (vla-item line-obj 0))
(vlax-for line-obj (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
; 检查是否为直线
(if (= (vla-get-objectname line-obj) "AcDbLine")
(progn
; 获取直线的两个端点
(setq pt1 (vla-get-startpoint line-obj)
pt2 (vla-get-endpoint line-obj))
; 检查是否为水平线 (Y坐标相等)
(if (< (abs (- (vla-get-y pt1) (vla-get-y pt2))) 1e-6)
(progn
; 水平线的Y坐标
(setq line-y (vla-get-y pt1))
; 计算直线的X范围
(setq min-x (min (vla-get-x pt1) (vla-get-x pt2))
max-x (max (vla-get-x pt1) (vla-get-x pt2)))
; 计算圆心到水平线的垂直距离
(setq dist (abs (- line-y (vla-get-y circle-center))))
; 检查距离是否小于等于圆半径 (可能相交)
(if (<= dist circle-radius)
(progn
; 计算圆与水平线交点的X坐标
(setq x-intercept (sqrt (- (* circle-radius circle-radius) (* dist dist))))
; 检查交点是否在直线段上
(if (or (and (>= (+ (vla-get-x circle-center) x-intercept) min-x)
(<= (+ (vla-get-x circle-center) x-intercept) max-x))
(and (>= (- (vla-get-x circle-center) x-intercept) min-x)
(<= (- (vla-get-x circle-center) x-intercept) max-x)))
(progn
; 删除相交的水平线
(vla-delete line-obj)
(princ "\n已删除一条相交的水平线")
)
)
)
)
)
)
)
)
; 恢复系统变量
(setvar "cmdecho" 1)
(princ "\n操作完成!")
(princ)
)
czb203 发表于 2025-9-7 09:28
谢谢您的指导
下载来试说是程序有问题
我试着加了一个括号 )
但测试时提示
正在处理与圆相交的水平线...
Error: no function definition: VLA-GET-Y
好象是差函数
请您再看看
谢谢 本帖最后由 llsheng_73 于 2025-9-7 15:05 编辑
(vl-load-com)
(defun tt(p0 r p1 p2 / a b c d)
(setq a(*(distance p1 p2)(distance p1 p2))
b(*(apply'+(mapcar '*(mapcar'- p2 p1)(mapcar'- p1 p0)))2)
c(-(*(distance p1 p0)(distance p1 p0))(* r r)))
(or(MINUSP(setq d(-(* b b)(* 4 a c))))
(vl-every(function(lambda(x)(or(MINUSP x)(< 1 x))))
(list(/(-(sqrt d) b)a 2)(/(+(sqrt d) b)a -2)))))
(defun c:tt(/ s obj p0 r a b)
(if(or(PROMPT"\n\r请选择一个圆: ")
(setq s(ssget":E:S"'((0 . "circle")))))
(progn
(vlax-invoke-method(vlax-ename->vla-object(setq obj(ssname s 0)))'GetBoundingBox 'a 'b)
(setq obj(entget obj)
p0(cdr(assoc 10 obj))
r(cdr(assoc 40 obj))
s(ssget"C"(vlax-safearray->list a)(vlax-safearray->list b)'((0 . "line"))))
(vl-every(function(lambda(x / a b)
(if(=(type(setq x(cadr x)))'ename)
(progn(setq a(mapcar'+(vlax-curve-getstartpoint x)'(0 0))
b(vlax-curve-getendpoint x))
(if(equal(cadr a)(cadr b)1e-8)
(or(tt p0 r a b)(entdel x)))))
t))
(ssnamex s))
)
)
) llsheng_73 发表于 2025-9-7 15:00
谢谢 73 大师的热心指导
程序很好，瞬间完成任务
大师高风亮节，技术顶尖
衷心感谢 ynhh 发表于 2025-9-7 17:20
谢谢 73 大师的热心指导
程序很好，瞬间完成任务
大师高风亮节，技术顶尖
感谢不能光口头上，要给明经币
页:
[1]