明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1154|回复: 5

[已解答] 如何将圆弧及直线的重合端点放到一个表、非重合端点放到另一个表中

[复制链接]
发表于 2014-10-30 14:05 | 显示全部楼层 |阅读模式
本帖最后由 Kye 于 2014-10-31 16:34 编辑

;;
USER2128namezg 两位老师指导下,可以实现上次贴子的要求,见5楼程序,
但是遇到新问题: 没有重合的端点怎么也弄不到一个表中,继续求老师们给指点如何将没有重合的端点放到另一个表中



;;


这个程序是路人老师的,提取直线的端点及相同端点,我想改成可以提取LINEARC类型的所有端点及相同端点,修改了其中的子函数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)
)





本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2014-10-30 15:52 | 显示全部楼层
查找相同点,须加入误差控制,如:(equal pt1 pt2 1e-6)。
发表于 2014-10-30 21:11 | 显示全部楼层
一般(equal pt1 pt2 0.0001)即可。当然允许的误差精度还可以设的更高。
 楼主| 发表于 2014-10-30 21:32 | 显示全部楼层
谢谢楼上两位老师指点,容差没有用过,我再学习下试试能否解决
 楼主| 发表于 2014-10-31 15:13 | 显示全部楼层
本帖最后由 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 (/ SS1  ss   TOL    SAMEPOINTS
         SELECTCURVES  N   LINE    ENDPOINTS
         PT P1  P2
        )

  (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
)
 楼主| 发表于 2014-11-1 22:23 | 显示全部楼层
再次感谢USER2128老师 及namezg 老师热心指导,感谢伟大的G版,也感谢浏览此帖的众位老师,程序写的很乱,问题似乎是解决了
  1. (defun ss2lst (ss / l n) ;_by Gu_lx
  2.   (repeat (setq n (sslength ss))
  3.     (setq l (cons (ssname ss (setq n (1- n))) l))
  4.   )
  5.   l
  6. )




  7. (defun c:dividePoints (/  SS1   SS    TOL     SAMEPOINTS
  8.            UNSAMEPOINTS   N    LINE     ENDPOINTS
  9.            PT  P1   P2    TAGLST   X
  10.            TAG
  11.           )



  12.   (vl-load-com)
  13.   (setvar "cmdecho" 0)
  14.   (setq ss1 (ssget '((0 . "*LINE,ARC"))))
  15.   (setq ss (ss2lst ss1))

  16.   (setq tol (getreal "\n 容差值<0.001>:"))
  17.   (if (null tol)
  18.     (setq tol 0.001)
  19.   ) ;_if
  20.   (setq  SamePoints
  21.          '()
  22.   UnSamePoints '()

  23.   )

  24.   (setq n 0)

  25.   (repeat (sslength ss1)

  26.     (setq line (ssname ss1 n))

  27.     (setq endPoints (list (vlax-curve-getstartpoint line)
  28.         (vlax-curve-getendpoint line)
  29.         )
  30.     )
  31.     (setq ss (vl-remove line ss))
  32.     (while endPoints
  33.       (setq pt        (car endPoints)
  34.       EndPoints (cdr EndPoints)
  35.       )

  36.       (foreach a ss
  37.   (setq p1 (vlax-curve-getstartpoint a)
  38.         p2 (vlax-curve-getendpoint a)
  39.   )

  40.   (if (equal p1 pt tol)
  41.     (progn (foreach x SamePoints
  42.        (if (equal p1 x tol)
  43.          (setq SamePoints (vl-remove x SamePoints))
  44.        )
  45.      )
  46.      (setq SamePoints (cons p1 SamePoints))

  47.     )
  48.   )
  49.   (if (equal p2 pt tol)
  50.     (progn (foreach x SamePoints
  51.        (if (equal p2 x tol)
  52.          (setq SamePoints (vl-remove x SamePoints))
  53.        )
  54.      )
  55.      (setq SamePoints (cons p2 SamePoints))
  56.     ) ;_PROGN

  57.   ) ;_IF

  58.       );_foreach


  59. ;;;;___________________________________________

  60.       (setq taglst
  61.        (mapcar
  62.          '(lambda  (x)
  63.       (progn
  64.         (setq p1 (vlax-curve-getstartpoint x))
  65.         (setq p2 (vlax-curve-getendpoint x))
  66.         (if
  67.           (and (not (equal p1 pt tol)) (not (equal p2 pt tol)))
  68.            (setq x 1)
  69.            (setq x 0)
  70.         ) ;_if
  71.       ) ;_progn
  72.     ) ;_lambda
  73.          ss
  74.        ) ;_mapcar
  75.       ) ;_setq

  76.       (if (null (vl-position (setq tag 0) taglst))

  77.   (setq UnSamePoints (cons pt UnSamePoints))
  78.       )

  79. ;;;;___________________________________________


  80.     ) ;_while
  81.     (setq n (1+ n))
  82.     (setq ss (ss2lst ss1))
  83.   )

  84.   (princ)
  85.   (list samepoints UnSamePoints)

  86. )
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 18:03 , Processed in 0.204407 second(s), 27 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表