设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 判断闭合轮廓的程序，求高手优化！
返回列表 发新帖
查看: 1652|回复: 4

[已解答] 判断闭合轮廓的程序，求高手优化！

[复制链接]
atjsking
发表于 2013-11-6 20:13:32 | 显示全部楼层 |阅读模式
;求简化优化下面的程序，
;查找不闭合点，由 "ARC"    "LINE"   "SPLINE"   "LWPOLYLINE" 组成的轮廓
;现在的问题是对单张图为全部选择，希望达到的效果是，框选图元 ，做类型判断

;1、选择所有
;2、判断类型
;     在圆弧两端50  51做圆
;     在直线两端10 11做圆
;     在曲线和多线10做圆
;3 选择所有的圆，判断同心的删除

(defun c:bfb()
  (setvar "cmdecho" 0)
  (alert "设定标记颜色默认<绿色>")
  (setq cc (acad_colordlg 3))
  (alert "设定标记圆直径默认<3>")
  (setq rc (getreal "\n指定标记圆的直径<3>："))
  (if (= rc nil) (setq rc 3))


  ;做选择集
(setq ss1(ssget "X"'((0 . "ARC")))
       ss2(ssget "X"'((0 . "LINE")))
       ss3(ssget "X"'((0 . "SPLINE")))
       ss4(ssget "X"'((0 . "LWPOLYLINE"))))
  (setq i1 0
        i2 0
        i3 0
        i4 0)

  ;对圆弧两端做圆
  (repeat (sslength ss1)
    (setq en1 (ssname ss1 i1))
    (setq en1zm (entget en1))
    (setq p0 (cdr(assoc 10 en1zm)))
    (setq pl (cdr(assoc 40 en1zm)))
    (setq p1a (cdr(assoc 50 en1zm)))
    (setq p2a (cdr(assoc 51 en1zm)))
    (setq p1 (polar p0 p1a pl )
          p2 (polar p0 p2a pl ))
    (setq i1 (1+ i1))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p1)(cons 40 (/ rc 2)) (cons 62 cc)))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p2)(cons 40 (/ rc 2)) (cons 62 cc)))
    )

     ;对直线两端做圆
  (repeat (sslength ss2)
    (setq en2 (ssname ss2 i2))
    (setq en2zm (entget en2))
    (setq p3 (cdr (assoc 10 en2zm ))
          p4 (cdr (assoc 11 en2zm )))
    (setq i2 (1+ i2))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p3)(cons 40 (/ rc 2)) (cons 62 cc)))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p4)(cons 40 (/ rc 2)) (cons 62 cc)))
    )


    ;对曲线两端做圆
  (repeat (sslength ss3)
    (setq en3 (ssname ss3 i3))
    (setq en3zm (entget en3))
    (setq p5 (cdr (assoc 10 en3zm ))
          p6 (cdr (assoc 10 (reverse en3zm ))))
    (setq i3 (1+ i3))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p5)(cons 40 (/ rc 2)) (cons 62 cc)))
    (entmake (list(cons 0 "CIRCLE")(cons 10 p6)(cons 40 (/ rc 2)) (cons 62 cc)))
    )



    ;对多线两端做圆
    (repeat (sslength ss4)
      (setq en4 (ssname ss4 i4))
      (setq en4zm (entget en4))
      (setq p7 (cdr (assoc 10 en4zm ))
            p8 (cdr (assoc 10 (reverse en4zm ))))
      (setq i4 (1+ i4))
      (entmake (list(cons 0 "CIRCLE")(cons 10 p7)(cons 40 (/ rc 2)) (cons 62 cc)))
      (entmake (list(cons 0 "CIRCLE")(cons 10 p8)(cons 40 (/ rc 2)) (cons 62 cc)))
    )

;删除同心圆程序，由网友<llsheng_73>提供，此处致以谢意！
(setq ss(ssget "X"'((0 . "circle"))))
(if ss(progn
  (setq m(sslength ss)n 0)
  (while(< n m)
    (setq e(ssname ss n)
    n(1+ n)
    p(assoc 10(entget e))
    l n
    a nil)
    (while(< l m)
      (setq f(ssname ss l)l(1+ l)
      p1(entget f))
      (if(vl-position p p1)
        (progn
    (ssdel f ss)
    (entdel f)
    (setq l(1- l)
          m(1- m)
          a t))))
    (if a(progn
     (ssdel e ss)
     (entdel e)
     (setq n(1- n)
           m(1- m))))
    )
  ))

  (princ)
  )


程序, 同心

相关帖子
回复

使用道具 举报

ZZXXQQ
发表于 2013-11-7 08:10:21 | 显示全部楼层
  2. ;1、窗选
  3. ;2、判断类型
  4. ;     在圆弧两端50  51做圆
  5. ;     在直线两端10 11做圆
  6. ;     在曲线和多线10做圆
  7. ;3 选择所有的圆，判断同心的删除
  8. (defun c:bfb()
  9.   (setvar "cmdecho" 0)
  10.   (alert "设定标记颜色默认<绿色>")
  11.   (setq cc (acad_colordlg 3))
  12.   (alert "设定标记圆直径默认<3>")
  13.   (setq rc (getreal "\n指定标记圆的直径<3>："))
  14.   (if (= rc nil) (setq rc 3))
  15.   ;做选择集
  16.   (setq pt1 (getpoint "\n窗选角点: "))
  17.   (setq pt2 (getcorner pt1 "\n另一角点: "))
  18.   (setq ss1(ssget "W" pt1 pt2 '((0 . "ARC")))
  19.        ss2(ssget "W" pt2  pt1 '((0 . "LINE")))
  20.        ss3(ssget "W" pt1 pt2 '((0 . "SPLINE")))
  21.        ss4(ssget "W" pt2 pt1 '((0 . "LWPOLYLINE"))))
  22.   (setq i1 0
  23.         i2 0
  24.         i3 0
  25.         i4 0)
  26.   ;对圆弧两端做圆
  27.   (repeat (sslength ss1)
  28.     (setq en1zm (entget (ssname ss1 i1)))
  29.     (setq p0 (cdr(assoc 10 en1zm)))
  30.     (setq pl (cdr(assoc 40 en1zm)))
  31.     (setq p1a (cdr(assoc 50 en1zm)))
  32.     (setq p2a (cdr(assoc 51 en1zm)))
  33.     (setq p1 (polar p0 p1a pl )
  34.           p2 (polar p0 p2a pl ))
  35.     (setq i1 (1+ i1))
  36.     (entmake (list(cons 0 "CIRCLE")(cons 10 p1)(cons 40 (/ rc 2)) (cons 62 cc)))
  37.     (entmake (list(cons 0 "CIRCLE")(cons 10 p2)(cons 40 (/ rc 2)) (cons 62 cc)))
  38.     )
  39.      ;对直线两端做圆
  40.   (repeat (sslength ss2)
  41.     (setq en2zm (entget (ssname ss2 i2)))
  42.     (setq p3 (cdr (assoc 10 en2zm ))
  43.           p4 (cdr (assoc 11 en2zm )))
  44.     (setq i2 (1+ i2))
  45.     (entmake (list(cons 0 "CIRCLE")(cons 10 p3)(cons 40 (/ rc 2)) (cons 62 cc)))
  46.     (entmake (list(cons 0 "CIRCLE")(cons 10 p4)(cons 40 (/ rc 2)) (cons 62 cc)))
  47.    )
  48.     ;对曲线两端做圆
  49.   (repeat (sslength ss3)
  50.     (setq en3zm (entget (ssname ss3 i3)))
  51.     (setq p5 (cdr (assoc 10 en3zm ))
  52.           p6 (cdr (assoc 10 (reverse en3zm ))))
  53.     (setq i3 (1+ i3))
  54.     (entmake (list(cons 0 "CIRCLE")(cons 10 p5)(cons 40 (/ rc 2)) (cons 62 cc)))
  55.     (entmake (list(cons 0 "CIRCLE")(cons 10 p6)(cons 40 (/ rc 2)) (cons 62 cc)))
  56.     )
  57.     ;对多线两端做圆
  58.     (repeat (sslength ss4)
  59.       (setq en4zm (entget (ssname ss4 i4)))
  60.       (setq p7 (cdr (assoc 10 en4zm ))
  61.             p8 (cdr (assoc 10 (reverse en4zm ))))
  62.       (setq i4 (1+ i4))
  63.       (entmake (list(cons 0 "CIRCLE")(cons 10 p7)(cons 40 (/ rc 2)) (cons 62 cc)))
  64.       (entmake (list(cons 0 "CIRCLE")(cons 10 p8)(cons 40 (/ rc 2)) (cons 62 cc)))
  65.     )
  66. ;删除同心圆程序，由网友<llsheng_73>提供，此处致以谢意！
  67.   
  68.   (if (setq ss(ssget "W" pt2 pt1 '((0 . "circle")))) (progn
  69.    (setq m(sslength ss)n 0)
  70.    (while(< n m)
  71.     (setq e(ssname ss n)
  72.     n(1+ n)
  73.     p(assoc 10(entget e))
  74.     l n
  75.     a nil)
  76.     (while(< l m)
  77.      (setq f(ssname ss l)l(1+ l)
  78.       p1(entget f))
  79.      (if(vl-position p p1) (progn
  80.       (ssdel f ss)
  81.       (entdel f)
  82.       (setq l(1- l)
  83.           m(1- m)
  84.           a t)
  85.      ))
  86.     )
  87.     (if a(progn
  88.      (ssdel e ss)
  89.      (entdel e)
  90.      (setq n(1- n)
  91.            m(1- m))
  92.     ))
  93.    )
  94.   ))
  95.   (princ)
  96. )
回复 支持 反对

使用道具 举报

atjsking
 楼主| 发表于 2013-11-7 12:28:05 | 显示全部楼层
ZZXXQQ 发表于 2013-11-7 08:10

程序BUG ，对“ARC”两端的圆删除不了……
回复 支持 反对

使用道具 举报

Andyhon
发表于 2013-11-7 12:54:27 | 显示全部楼层
一般程序只会依当时的需求从简编定
合乎甲 未必 合乎乙

暨是条件有差,就得依实务修定
这就意谓着,得学些编程...
回复 支持 反对

使用道具 举报

wuqiu1986
发表于 2013-11-7 19:49:52 | 显示全部楼层
  2. (defun c:bfb ()
  3.   (setvar "cmdecho" 0)
  4.   (alert "设定标记颜色默认<绿色>")
  5.   (setq cc (acad_colordlg 3))
  6.   (alert "设定标记圆直径默认<3>")
  7.   (setq rc (getreal "\n指定标记圆的直径<3>："))
  8.   (if (= rc nil)
  9.     (setq rc 3)
  10.   )
  11.   (setq        ss (ssget (LIST
  12.                     '(-4 . "<OR")
  13.                     '(0 . "LINE,ARC")
  14.                     '(-4 . "<AND")
  15.                     '(0 . "ELLIPSE")
  16.                     '(-4 . "<OR")
  17.                     '(-4 . "<>")
  18.                     '(41 . 0.0)
  19.                     '(-4 . "<>")
  20.                     (cons 42 (* pi 2))
  21.                     '(-4 . "OR>")
  22.                     '(-4 . "AND>")
  23.                     '(-4 . "<AND")
  24.                     '(0 . "LWPOLYLINE,SPLINE")
  25.                     '(-4 . "<NOT")
  26.                     '(-4 . "&=")
  27.                     '(70 . 1)
  28.                     '(-4 . "NOT>")
  29.                     '(-4 . "AND>")
  30.                     '(-4 . "<AND")
  31.                     '(0 . "PLOYLINE")
  32.                     '(-4 . "<NOT")
  33.                     '(-4 . "&")
  34.                     '(70 . 89)
  35.                     '(-4 . "NOT>")
  36.                     '(-4 . "AND>")
  37.                     '(-4 . "OR>")
  38.                     (if        (= 1 (getvar 'cvport))
  39.                       (cons 410 (getvar 'ctab))
  40.                       '(410 . "Model")
  41.                     )
  42.                   )
  43.            )
  44.   )
  45.   (setq i 0)
  46.   (if ss
  47.     (repeat (sslength ss)
  48.       (setq en (ssname ss i))
  49.       (setq spt        (vlax-curve-getstartpoint en)
  50.             ept        (vlax-curve-getendpoint en)
  51.       )
  52.       (entmake (list (cons 0 "CIRCLE")
  53.                      (cons 10 spt)
  54.                      (cons 40 (/ rc 2))
  55.                      (cons 62 cc)
  56.                )
  57.       )
  58.       (entmake (list (cons 0 "CIRCLE")
  59.                      (cons 10 ept)
  60.                      (cons 40 (/ rc 2))
  61.                      (cons 62 cc)
  62.                )
  63.       )
  64.       (setq i (1+ i))
  65.     )
  66.   )
  67. ）
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-22 21:14 , Processed in 0.200078 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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