atjsking 发表于 2013-11-6 20:13:32

判断闭合轮廓的程序,求高手优化!

;求简化优化下面的程序,
;查找不闭合点,由 "ARC"    "LINE"   "SPLINE"   "LWPOLYLINE" 组成的轮廓
;现在的问题是对单张图为全部选择,希望达到的效果是,框选图元 ,做类型判断

;1、选择所有
;2、判断类型
;   在圆弧两端5051做圆
;   在直线两端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

;1、窗选
;2、判断类型
;   在圆弧两端5051做圆
;   在直线两端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 pt1 (getpoint "\n窗选角点: "))
(setq pt2 (getcorner pt1 "\n另一角点: "))
(setq ss1(ssget "W" pt1 pt2 '((0 . "ARC")))
       ss2(ssget "W" pt2pt1 '((0 . "LINE")))
       ss3(ssget "W" pt1 pt2 '((0 . "SPLINE")))
       ss4(ssget "W" pt2 pt1 '((0 . "LWPOLYLINE"))))
(setq i1 0
      i2 0
      i3 0
      i4 0)
;对圆弧两端做圆
(repeat (sslength ss1)
    (setq en1zm (entget (ssname ss1 i1)))
    (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 en2zm (entget (ssname ss2 i2)))
    (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 en3zm (entget (ssname ss3 i3)))
    (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 en4zm (entget (ssname ss4 i4)))
      (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>提供,此处致以谢意!

(if (setq ss(ssget "W" pt2 pt1 '((0 . "circle")))) (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)
)

atjsking 发表于 2013-11-7 12:28:05

ZZXXQQ 发表于 2013-11-7 08:10 static/image/common/back.gif


程序BUG ,对“ARC”两端的圆删除不了……

Andyhon 发表于 2013-11-7 12:54:27

一般程序只会依当时的需求从简编定
合乎甲 未必 合乎乙

暨是条件有差,就得依实务修定
这就意谓着,得学些编程...

wuqiu1986 发表于 2013-11-7 19:49:52

(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        ss (ssget (LIST
                  '(-4 . "<OR")
                  '(0 . "LINE,ARC")
                  '(-4 . "<AND")
                  '(0 . "ELLIPSE")
                  '(-4 . "<OR")
                  '(-4 . "<>")
                  '(41 . 0.0)
                  '(-4 . "<>")
                  (cons 42 (* pi 2))
                  '(-4 . "OR>")
                  '(-4 . "AND>")
                  '(-4 . "<AND")
                  '(0 . "LWPOLYLINE,SPLINE")
                  '(-4 . "<NOT")
                  '(-4 . "&=")
                  '(70 . 1)
                  '(-4 . "NOT>")
                  '(-4 . "AND>")
                  '(-4 . "<AND")
                  '(0 . "PLOYLINE")
                  '(-4 . "<NOT")
                  '(-4 . "&")
                  '(70 . 89)
                  '(-4 . "NOT>")
                  '(-4 . "AND>")
                  '(-4 . "OR>")
                  (if        (= 1 (getvar 'cvport))
                      (cons 410 (getvar 'ctab))
                      '(410 . "Model")
                  )
                  )
           )
)
(setq i 0)
(if ss
    (repeat (sslength ss)
      (setq en (ssname ss i))
      (setq spt        (vlax-curve-getstartpoint en)
          ept        (vlax-curve-getendpoint en)
      )
      (entmake (list (cons 0 "CIRCLE")
                     (cons 10 spt)
                     (cons 40 (/ rc 2))
                     (cons 62 cc)
             )
      )
      (entmake (list (cons 0 "CIRCLE")
                     (cons 10 ept)
                     (cons 40 (/ rc 2))
                     (cons 62 cc)
             )
      )
      (setq i (1+ i))
    )
)
页: [1]
查看完整版本: 判断闭合轮廓的程序,求高手优化!