如何将圆弧及直线的重合端点放到一个表、非重合端点放到另一个表中
本帖最后由 Kye 于 2014-10-31 16:34 编辑;;
在USER2128 及namezg 两位老师指导下，可以实现上次贴子的要求，见5楼程序，
但是遇到新问题： 没有重合的端点怎么也弄不到一个表中，继续求老师们给指点如何将没有重合的端点放到另一个表中
;;
这个程序是路人老师的，提取直线的端点及相同端点，我想改成可以提取LINE，ARC类型的所有端点及相同端点，修改了其中的子函数Get_line_point后，获取选取线的所有端点没有问题；但提取同一端点时遇到问题：1. 测试时两根线为LINE类型，可以提取出同一端点2. 一种为ARC类型，另一种为LINE类型时或两线都为ARC类型，程序有时能提取出来同一端点（例如测试附件中的A），有时提取不出来（例如测试附件中的B）
测试很长时间，测试中除XP:Flatten没有被替换，其他函数用过相似函数替换，结果一样，没有找到原因，哪位大侠百忙中抽空帮忙指点指点，谢谢了。附件是测试的DWG文件
;;;选择集转vla图元表
;;;ss->vla List
(defun LM:ss->vla(SS / E I L)
(if ss
((lambda (i / e L)
(while (setq e (ssname ss (setq i (1+ i))))
(setq L (cons (vlax-ename->vla-object e) L))
)
L
)
-1
)
)
);;;提取线的端点
(defun Get_line_point (SS / PT PTS)(mapcar '(lambda (x / pt pts)
(progn
(setq pt (vlax-curve-getendpoint x))
(setq pts (cons pt pts))
(setq pt (vlax-curve-getstartpoint x))
(setq pts (cons pt pts))
) ;_progn
) ;_lambda
ss
) ;_mapcar
)
;;;多层表转换单层表
(defun XP:Flatten (lst)
(if lst
(if (listp (car lst))
(append (XP:Flatten (car lst)) (XP:Flatten (cdr lst)))
(list lst)
)
)
);;;提取相同点, by 阿然
(defun findsame (lst)
(if lst
(if (member (car lst) (cdr lst))
(append (list (car lst)) (findsame (cdr lst)))
(findsame (cdr lst))
)
)
)(defun findsame2 (l1 / l2) ;_by llsheng_73
;;;查找表中重复元素
(while l1
(if (member (car l1) (cdr l1))
;_(setq l2 (append l2 (list (car l1))))
(setq l2 (cons (car l1) l2)) )
(setq l1 (vl-remove (car l1) l1))
)
l2
)
;;;删除重复制点,保留一个点(defun gxl-delsame (L);_by Gu_lx
(if L
(cons (car L) (gxl-delsame (vl-remove (car L) (cdr L))))
)
)
(defun c:tt (/ SS PTS pts1)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ss (ssget '((0 . "*LINE,ARC"))))(setq ss (LM:ss->vla ss));选择集转vla图元表
(setq pts (Get_line_point ss));提取线的端点(setq pts (XP:Flatten pts));多层表转换单层表,获取所有端点(princ "\n 所有端点\n")
(print pts)
(princ "\n 所有端点\n")(setq pts1 (findsame pts));;提取相同端点 (princ "\n 提取出相同端点\n")
(print pts1)
(princ "\n 提取出相同端点\n")(princ)
)
查找相同点，须加入误差控制，如：(equal pt1 pt2 1e-6)。 一般(equal pt1 pt2 0.0001)即可。当然允许的误差精度还可以设的更高。 谢谢楼上两位老师指点，容差没有用过，我再学习下试试能否解决 本帖最后由 Kye 于 2014-10-31 15:42 编辑
在二楼和三楼老师的指点下，学习了G版的程序，也没有全看懂，能把重合的端点取出来（多余两根线重合端点，会重复取），但是没有重合的端点怎么也弄不到一个表中，继续求老师们给指点如何将没有重合的端点放到另一个表中
(defun ss2lst (ss / l n) ;_by Gu_lx
(repeat (setq n (sslength ss))
(setq l (cons (ssname ss (setq n (1- n))) l))
)
l
)
(defun gxl-delsame (L) ;_by Gu_lx
(if L
(cons (car L) (gxl-delsame (vl-remove (car L) (cdr L))))
)
)
(defun c:dividePoints (/ SS1ss TOL SAMEPOINTS
SELECTCURVESN LINE ENDPOINTS
PT P1P2
)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ss1 (ssget '((0 . "*LINE,ARC"))))
(setq ss (ss2lst ss1))
(setq tol (getreal "\n 容差值<0.001>:"))
(if (null tol)
(setq tol 0.001)
) ;_if
(setq SamePoints
'()
;_UnSamePoints '()
;_SelectCurves '()
)
(setq n 0)
(repeat (sslength ss1)
(setq line (ssname ss1 n))
(setq endPoints (list (vlax-curve-getstartpoint line)
(vlax-curve-getendpoint line)
)
)
(setq ss (vl-remove line ss))
;_(setq SelectCurves (cons line SelectCurves))
(while endPoints
(setq pt (car endPoints)
EndPoints (cdr EndPoints)
)
(foreach a ss
(setq p1 (vlax-curve-getstartpoint a)
p2 (vlax-curve-getendpoint a)
)
(if (equal p1 pt tol)
(setq SamePoints (cons p1 SamePoints))
)
(if (equal p2 pt tol)
(setq SamePoints (cons p2 SamePoints))
)
) ;_foreach
)
(setq n (1+ n))
;_(setq ss (ss2lst ss1))
)
(setq samepoints (gxl-delsame samepoints))
(princ)
samepoints
)
再次感谢USER2128老师 及namezg 老师热心指导，感谢伟大的G版，也感谢浏览此帖的众位老师，程序写的很乱，问题似乎是解决了(defun ss2lst (ss / l n) ;_by Gu_lx
(repeat (setq n (sslength ss))
(setq l (cons (ssname ss (setq n (1- n))) l))
)
l
)
(defun c:dividePoints (/SS1 SS TOL SAMEPOINTS
UNSAMEPOINTS N LINE ENDPOINTS
PTP1 P2 TAGLST X
TAG
)
(vl-load-com)
(setvar "cmdecho" 0)
(setq ss1 (ssget '((0 . "*LINE,ARC"))))
(setq ss (ss2lst ss1))
(setq tol (getreal "\n 容差值<0.001>:"))
(if (null tol)
(setq tol 0.001)
) ;_if
(setqSamePoints
'()
UnSamePoints '()
)
(setq n 0)
(repeat (sslength ss1)
(setq line (ssname ss1 n))
(setq endPoints (list (vlax-curve-getstartpoint line)
(vlax-curve-getendpoint line)
)
)
(setq ss (vl-remove line ss))
(while endPoints
(setq pt (car endPoints)
EndPoints (cdr EndPoints)
)
(foreach a ss
(setq p1 (vlax-curve-getstartpoint a)
p2 (vlax-curve-getendpoint a)
)
(if (equal p1 pt tol)
(progn (foreach x SamePoints
(if (equal p1 x tol)
(setq SamePoints (vl-remove x SamePoints))
)
)
(setq SamePoints (cons p1 SamePoints))
)
)
(if (equal p2 pt tol)
(progn (foreach x SamePoints
(if (equal p2 x tol)
(setq SamePoints (vl-remove x SamePoints))
)
)
(setq SamePoints (cons p2 SamePoints))
) ;_PROGN
) ;_IF
);_foreach
;;;;___________________________________________
(setq taglst
(mapcar
'(lambda(x)
(progn
(setq p1 (vlax-curve-getstartpoint x))
(setq p2 (vlax-curve-getendpoint x))
(if
(and (not (equal p1 pt tol)) (not (equal p2 pt tol)))
(setq x 1)
(setq x 0)
) ;_if
) ;_progn
) ;_lambda
ss
) ;_mapcar
) ;_setq
(if (null (vl-position (setq tag 0) taglst))
(setq UnSamePoints (cons pt UnSamePoints))
)
;;;;___________________________________________
) ;_while
(setq n (1+ n))
(setq ss (ss2lst ss1))
)
(princ)
(list samepoints UnSamePoints)
)
页:
[1]