[原创]：高效的合并直线程序，敬请使用。

eachy · 发表于 2004-6-1 06:29:43

1 索引用字符方法不错，用实数时发现 assoc 因为浮点运算不能检索正确结果
2 单独测试构造表部分，约18000个重复实体耗时1.6s

说到表长，还是建议分区域选择，多消几次的累计时间比一次全选可能还要少。28000个重复实体选择时如果打开了亮显，仅响应就要呆一会儿。

lijiao · 发表于 2004-6-1 14:56:24

进行了一些优化，速度快了不少。

[FONT=courier new]
(defun c:hbzhx (/ jinnd ss ss1 ss2 ss3 ss4 sslay p1 p2 xuhao zongshu ssbak step val biaoji)
(cond
((and
(setq ss (ssget (list (cons 0 "LINE"))))
(> (sslength ss) 1)
)
(setq zongshu (/ 100.0 (sslength ss)))
(setq xuhao 0
step 1
jingd 0.001
)
(acet-ui-progress "已经完成" 100)
(setq ssbak ss)
(while (> (sslength ss) 0)
(setq ss1 (ssname ss 0)
ss (ssdel ss1 ss)
)
(setq biaoji nil)
(setq xuhao (+ xuhao zongshu))
(if (= (fix xuhao) step)
(progn
(acet-ui-progress -1)
(setq step (1+ step))
)
)
(setq p1 (vlax-curve-getstartpoint ss1)
p2 (vlax-curve-getendpoint ss1)
)
(setq sslay (vla-get-layer (vlax-ename->vla-object ss1)))
(setq ss3 (ssget "c" p1 p1 (list (cons 0 "LINE") (cons 8 sslay))))
(setq ss4 (ssget "c" p2 p2 (list (cons 0 "LINE") (cons 8 sslay))))
(setq ss3 (ssdel ss1 ss3))
(setq ss4 (ssdel ss1 ss4))
(repeat (sslength ss3)
(setq ss2 (ssname ss3 0)
ss3 (ssdel ss2 ss3)
)
(if (setq val (hbline p1 p2 ss2 jingd))
(progn
(if (ssmemb ss2 ss)
(setq ss (ssdel ss2 ss))
)
(if (ssmemb ss2 ss4)
(setq ss4 (ssdel ss2 ss4))
)
(setq xuhao (+ xuhao zongshu))
(if (= (fix xuhao) step)
(progn
(acet-ui-progress -1)
(setq step (1+ step))
)
)
(entdel ss2)
(setq p1 (car val)
p2 (cadddr val)
biaoji t)
)
)
)
(repeat (sslength ss4)
(setq ss2 (ssname ss4 0)
ss4 (ssdel ss2 ss4)
)
(if (setq val (hbline p1 p2 ss2 jingd))
(progn
(if (ssmemb ss2 ss)
(setq ss (ssdel ss2 ss))
)
(setq xuhao (+ xuhao zongshu))
(if (= (fix xuhao) step)
(progn
(acet-ui-progress -1)
(setq step (1+ step))
)
)
(entdel ss2)
(setq p1 (car val)
p2 (cadddr val)
biaoji t)
)
)
)
(if biaoji
(progn
(setq ss1 (entget ss1 (list "*"))
ss1 (subst (cons 10 p1) (assoc 10 ss1) ss1)
ss1 (subst (cons 11 p2) (assoc 11 ss1) ss1)
)
(entmod ss1)
)
)
)
(acet-ui-progress)
)
(t nil)
)
(princ)
)
(defun hbline (p1 p2 ent jingd / p3 p4 dis1 dis2 dis3 dis4 dis)
(setq p3 (vlax-curve-getstartpoint ent)
p4 (vlax-curve-getendpoint ent)
dis (distance p1 p2)
dis1 (distance p1 p3)
dis2 (distance p2 p3)
dis3 (distance p1 p4)
dis4 (distance p2 p4)
)
(if (and
(equal (+ dis dis1 dis2)
(* 2.0 (max dis dis1 dis2))
jingd
)
(equal (+ dis dis3 dis4)
(* 2.0 (max dis dis3 dis4))
jingd
)
)
(setq p4 (vl-sort (list p1 p2 p3 p4)
'(lambda (e1 e2)
(if (equal (car e1) (car e2) 1e-5)
(< (cadr e1) (cadr e2))
(< (car e1) (car e2))
)
)
)
)
)
)
[/FONT]

[FONT=courier new] 
(defun c:hbzhx (/ jinnd ss ss1 ss2 ss3 ss4 sslay p1 p2 xuhao zongshu ssbak step val biaoji) 
  (cond 
    ((and 
       (setq ss (ssget (list (cons 0 "LINE")))) 
       (> (sslength ss) 1) 
     ) 
     (setq zongshu (/ 100.0 (sslength ss))) 
     (setq xuhao 0 
           step        1 
           jingd 0.001 
     ) 
     (acet-ui-progress "已经完成" 100) 
     (setq ssbak ss) 
     (while (> (sslength ss) 0) 
       (setq ss1 (ssname ss 0) 
             ss         (ssdel ss1 ss) 
       ) 
       (setq biaoji nil) 
       (setq xuhao (+ xuhao zongshu)) 
       (if (= (fix xuhao) step) 
         (progn 
           (acet-ui-progress -1) 
           (setq step (1+ step)) 
         ) 
       ) 
       (setq p1        (vlax-curve-getstartpoint ss1) 
             p2        (vlax-curve-getendpoint ss1) 
       ) 
       (setq sslay (vla-get-layer (vlax-ename->vla-object ss1))) 
       (setq ss3 (ssget "c" p1 p1 (list (cons 0 "LINE") (cons 8 sslay)))) 
       (setq ss4 (ssget "c" p2 p2 (list (cons 0 "LINE") (cons 8 sslay)))) 
       (setq ss3 (ssdel ss1 ss3)) 
       (setq ss4 (ssdel ss1 ss4)) 
       (repeat (sslength ss3) 
         (setq ss2 (ssname ss3 0) 
               ss3 (ssdel ss2 ss3) 
         ) 
         (if (setq val (hbline p1 p2 ss2 jingd)) 
           (progn 
             (if (ssmemb ss2 ss) 
               (setq ss (ssdel ss2 ss)) 
             ) 
             (if (ssmemb ss2 ss4) 
               (setq ss4 (ssdel ss2 ss4)) 
             ) 
             (setq xuhao (+ xuhao zongshu)) 
             (if (= (fix xuhao) step) 
               (progn 
                 (acet-ui-progress -1) 
                 (setq step (1+ step)) 
               ) 
             ) 
             (entdel ss2) 
             (setq p1 (car val) 
                   p2 (cadddr val) 
                   biaoji t) 
           ) 
         ) 
       ) 
       (repeat (sslength ss4) 
         (setq ss2 (ssname ss4 0) 
               ss4 (ssdel ss2 ss4) 
         ) 
         (if (setq val (hbline p1 p2 ss2 jingd)) 
           (progn 
             (if (ssmemb ss2 ss) 
               (setq ss (ssdel ss2 ss)) 
             ) 
             (setq xuhao (+ xuhao zongshu)) 
             (if (= (fix xuhao) step) 
               (progn 
                 (acet-ui-progress -1) 
                 (setq step (1+ step)) 
               ) 
             ) 
             (entdel ss2) 
             (setq p1 (car val) 
                   p2 (cadddr val) 
                   biaoji t) 
           ) 
         ) 
         ) 
       (if biaoji 
         (progn 
           (setq ss1 (entget ss1 (list "*")) 
                 ss1 (subst (cons 10 p1) (assoc 10 ss1) ss1) 
                 ss1 (subst (cons 11 p2) (assoc 11 ss1) ss1) 
                 ) 
           (entmod ss1) 
           ) 
         ) 
     ) 
     (acet-ui-progress) 
    ) 
    (t nil) 
  ) 
  (princ) 
) 
(defun hbline (p1 p2 ent jingd / p3 p4 dis1 dis2 dis3 dis4 dis) 
  (setq        p3   (vlax-curve-getstartpoint ent) 
        p4   (vlax-curve-getendpoint ent) 
        dis  (distance p1 p2) 
        dis1 (distance p1 p3) 
        dis2 (distance p2 p3) 
        dis3 (distance p1 p4) 
        dis4 (distance p2 p4) 
  ) 
  (if (and 
        (equal (+ dis dis1 dis2) 
               (* 2.0 (max dis dis1 dis2)) 
               jingd 
        ) 
        (equal (+ dis dis3 dis4) 
               (* 2.0 (max dis dis3 dis4)) 
               jingd 
        ) 
      ) 
    (setq p4 (vl-sort (list p1 p2 p3 p4) 
                      '(lambda (e1 e2) 
                         (if (equal (car e1) (car e2) 1e-5) 
                           (< (cadr e1) (cadr e2)) 
                           (< (car e1) (car e2)) 
                         ) 
                       ) 
             ) 
    ) 
  ) 
) 
  [/FONT]

aeo · 发表于 2004-6-2 01:02:36

最初由 eachy 发布
[B]1 索引用字符方法不错，用实数时发现 assoc 因为浮点运算不能检索正确结果
2 单独测试构造表部分，约18000个重复实体耗时1.6s

说到表长，还是建议分区域选择，多消几次的累计时间比一次全选可能还要少。28000个... [/B]

用assoc时间注定是随实体多少几何级上升
而lijiao的方法是代数级的

lijiao · 发表于 2004-6-2 07:53:07

当许多的不平行的直线具有同一个端点时，如直线绕其端点阵列，我的代码会显得很慢，而EACHY版主的代码会很快。
但在实际的使用中，这种情况很少，绝大多数是水平线和垂直线，具有同一端点的就更少。

eachy · 发表于 2004-6-12 01:22:39

最初由 lijiao 发布
[B]当许多的不平行的直线具有同一个端点时，如直线绕其端点阵列，我的代码会显得很慢，而EACHY版主的代码会很快。
但在实际的使用中，这种情况很少，绝大多数是水平线和垂直线，具有同一端点的就更少。 [/B]

再次优化，整体性巨大提高。原来要　２４ｓ，现在２ｓ
命令：　hbln

liuyj · 发表于 2004-6-14 10:29:17

ea兄的东东真是精品，速度确实快，把4000条直线合并为2000条只花了8s。但是以下两种情况是否可以也考虑一下？
1、两直线共线，但没有重合点，或者说一条直线中间断了一段；
2、增加对圆弧的支持。
另:可不可以编译成.fas文件发上来？十分感谢！

lhj743 · 发表于 2004-6-14 11:43:34

命令: hbzhx

选择对象: 找到 1 个

选择对象: 找到 1 个，总计 2 个

选择对象:
; 错误: no function definition: ACET-UI-PROGRESS
---------------
各位：我在R2004下怎么出现这种错误啊？

liuyj · 发表于 2004-6-14 12:04:29

最初由 lhj743 发布
[B] 错误: no function definition: ACET-UI-PROGRESS
---------------
各位：我在R2004下怎么出现这种错误啊？ [/B]

你没安装express for 2004

梦断江南 · 发表于 2004-7-30 20:42:15

试了lijiao的17贴，在处理重叠圆弧的时候，有丢失的情况？

lijiao · 发表于 2004-7-31 07:50:27

http://www.p4.xdcad.net/forum/sh ... amp;threadid=220682
中的第11贴已经解决了这些问题，并且更稳定，速度更快。

liuyj · 发表于 2004-8-2 08:57:14

可是我在那里写的东西和提的问题就没人理睬吗？:(

Gu_xl · 发表于 2005-6-16 13:21:47

斑竹的程序在直线不是连续重叠时有时会遗漏合并一些直线，下面是我对程序的改进，能将所有重叠的直线都合并！

(defun Sort-List-up (Lst)
(setq m (length Lst)
n 0
Lst1 '())
(repeat m
(setq Lst1 (cons (car (nth n Lst)) Lst1)
n (1+ n)
)
);repeat
(setq Lst1 (reverse Lst1))
(setq Lst1 (vl-sort-i Lst1 '<))
(setq Lst2 '()
n 0)
(repeat m
(setq Lst2 (cons (nth (nth n Lst1) Lst) Lst2)
n (1+ n)
)
);repeat
(setq Lst2 (reverse Lst2))
)
(defun I:GetInp
(PromptStr ; user prompt string
InpList ; list of allowed input strings
Default ; default option, nil if none
/
InitStr ; string for initget options
kWordStr ; string for user's input prompt
Inp ; user's input
) ;_ closes variable declare
(setq
kWordStr
(substr
(apply
'strcat ; make full string
(mapcar ; add preceeding / to each string
'(lambda (str) (strcat "/" str))
InpList
) ;_ closes mapcar
) ;_ closes apply
2 ; remove leading /
) ;_ closes substr
InitStr ; make string w/spaces, not /
;;; 以下用于 Visual LISP AutoCAD
(vl-string-translate "/" " " kWordStr)
;;; 结束选项
;;; 以下用于非 Visual LISP AutoCAD
;;; (substr
;;; (apply
;;; 'strcat
;;; (mapcar
;;; '(lambda (str) (strcat " " str))
;;; InpList
;;; ) ;_ closes mapcar
;;; ) ;_ closes apply
;;; 2
;;; ) ;_ closes substr
;;; 结束选项
PromptStr
(strcat
(if PromptStr
(strcat PromptStr " [")
"["
) ;_ closes if
kWordStr
"]" ; start default indication
(if Default
(strcat
" <"
(car (member Default InpList)) ; display default
">: "
) ;_ closes strcat
": "
) ;_ closes if
) ;_ closes strcat
) ;_ closes setq
(initget
(if Default 0 1) ; if default allow an
InitStr
) ;_ closes initget
; get input, if null, use default
(setq Inp (if (setq Inp (getkword PromptStr))
Inp
Default
) ;_ closes if
) ;_ closes setq
)
(defun vl-sort-enList (EnList / enl enl1 p1 p2 x1 x rtnList)
(foreach enl EnList
(progn
(setq ang (car enl)
enl (cdr enl)
)
(setq enl1
(mapcar '(LAMBDA (x)
(setq p1 (vlax-curve-getstartpoint x)
p2 (vlax-curve-getendpoint x)
)
(if (EQUAL ang (/ pi 2) CorJD)
(setq x1 (min (cadr p1) (cadr p2)))
(setq x1 (min (car p1) (car p2)))
)
(list x1 x)
);LAMBDA
enl
);mapcar
);setq
(setq enl1 (SORT-LIST-UP enl1))
(setq enl1 (mapcar 'cadr enl1)
enl1 (cons ang enl1))
(if rtnList
(setq rtnList (cons enl1 rtnList))
(setq rtnList (list enl1))
);if
);progn
);foreach
rtnList
);defun
(defun isOn (pt e)
(equal (vlax-curve-getclosestpointto e pt)
pt
CorJD
)
)
(defun hbline (ln1 ln2 / tf p0 p00 p1 p2 p3 p4)
(setq p1 (vlax-curve-getstartpoint ln1)
p2 (vlax-curve-getendpoint ln1)
p3 (vlax-curve-getstartpoint ln2)
p4 (vlax-curve-getendpoint ln2)
elst (entget ln1)
)
(if (or (ison p3 ln1)
(ison p4 ln1)
(ison p1 ln2)
(ison p2 ln2)
)
(progn
(setq pl (vl-sort (list p1 p2 p3 p4)
'(lambda (e1 e2)
(if (equal (car e1) (car e2) CorJD)
(< (cadr e1) (cadr e2))
(< (car e1) (car e2))
)
)
)
)
(setq elst (subst (cons 10 (car pl)) (assoc 10 elst) elst)
elst (subst (cons 11 (last pl)) (assoc 11 elst) elst)
)
(entmod elst)
(entdel ln2)
(setq delcount (1+ delcount))
)
)
(princ)
)
(defun hbzhx (/ a ang e e1 el ep oldlst sp ssl delcount)
(setq delcount 0)
(command ".undo" "g")
(setq ssl (sslength ss))
(while (> ssl 0)
(setq e (ssname ss (setq ssl (1- ssl)))
sp (vlax-curve-getstartpoint e)
ep (vlax-curve-getendpoint e)
ang (angle sp ep)
)
(if (>= ang pi)
(setq ang (read (rtos (- ang pi) 2 AngJD)))
(setq ang (read (rtos ang 2 AngJD)))
)
(if (not el)
(setq el (list (list ang e)))
(if (setq oldlst (assoc ang el))
(setq el (subst (append oldlst (list e))
oldlst
el
)
)
(setq el (append el (list (list ang e))))
)
)
) ;while
(setq el (vl-sort-enList el))
;;将直线按角度划分
(foreach i (mapcar 'cdr el)
(if (> (length i) 1)
(progn
(while i
(setq e1 (car i))
(setq i (cdr i))
(mapcar '(lambda (a)
;(if (and (not (vlax-erased-p e1))
; (not (vlax-erased-p a))
; )
(hbline e1 a)
; )
)
i
)
(setq i (VL-REMOVE-IF 'vlax-erased-p i))
)
)
)
)
(command ".undo" "e")
delcount
)
;;;ssel 为选择集，Condition 为过滤条件，返回两个选择集表，'(s1 s2)
;;;s1 为ssel 去除过滤条件后剩下元素的选择集，s2 按过滤条件选择的结果
(defun filter (ssel Condition / s1 s2 m n en enl)
(setq n (sslength ssel)
m 0
s1 (ssadd)
s2 (ssadd))
(while (> (setq m (sslength ssel)) 0)
(setq en (ssname ssel (1- m))
enl (entget en))
(if (VL-POSITION Condition enl)
(progn
(ssadd en s2)
(ssdel en ssel)
)
(progn
(ssadd en s1)
(ssdel en ssel)
)
)
);while
(ssunion (list ssel s1))
(list s1 s2)
)
(defun c:zxhb (/ ByFloor Sel AngJD CorJD LaList delcount t1 t2 t3 t4 t5 t6 t7 t8)
(setierr)
(setq Alldelcount 0)
(setq ByFloor (I:GetInp "\n按层合并直线Floor或按不层合并直线All"
'("Floor" "All") "Floor"))
(initget " " 5)
(setq AngJD (getint "\n直线角度的精度<5>:"))
;(princ "\n选择对象：")
(setq Sel (ssget '((0 . "line"))))
(if (= AngJD "") (setq AngJD 5))
(setq t1 (getvar "Cdate"))
(setq CorJD (expt 10.0 (* -1 AngJD)))
(setq k (sslength Sel)
ki 0)
(repeat k
(setq en (ssname Sel ki))
(setq La (vlax-get-property (vlax-ename->vla-object en) 'layer))
(if (not LaList)
(setq LaList (list La))
(if (not (VL-POSITION La LaList))
(setq LaList (cons La LaList))
);if
);if
(setq ki (1+ ki))
);repeat k
(setq k (length LaList)
ki 0)
(if (= "Floor" ByFloor)
(repeat k
(setq ss (cadr (FILTER sel (cons 8 (nth ki LaList)))))
(setq Alldelcount (+ Alldelcount (hbzhx)))
(setq ki (1+ ki))
)
(setq ss sel
Alldelcount (+ Alldelcount (hbzhx)))
)
(princ (strcat "\n滤除直线共计" (itoa Alldelcount) "条！"))
(setq t2 (getvar "Cdate"))
(setq t3 t1)
(setq t4 (fix (* 100 t3))
t5 (- (fix (* 10000 t3)) (* t4 100))
t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
t7 (+ (* t4 3600) (* t5 60) t6)
)
(setq t3 t2)
(setq t4 (fix (* 100 t3))
t5 (- (fix (* 10000 t3)) (* t4 100))
t6 (- (* 1000000 t3) (* t5 100) (* t4 10000))
t8 (+ (* t4 3600) (* t5 60) t6)
)
(princ "\n用时")
(princ (- t8 t7))
(princ "秒")
(reerr)
(princ)
)

(defun Sort-List-up (Lst) 
    (setq m (length Lst) 
          n 0 
          Lst1 '()) 
    (repeat m 
        (setq Lst1 (cons (car (nth n Lst)) Lst1) 
              n (1+ n) 
              ) 
        );repeat 
    (setq Lst1 (reverse Lst1)) 
    (setq Lst1 (vl-sort-i Lst1 '<)) 
    (setq Lst2 '() 
          n 0) 
    (repeat m 
        (setq Lst2 (cons (nth (nth n Lst1) Lst) Lst2) 
              n (1+ n) 
              ) 
        );repeat 
    (setq Lst2 (reverse Lst2)) 
              
        
    ) 
(defun I:GetInp 
 (PromptStr                 ; user prompt string 
  InpList                   ; list of allowed input strings 
  Default                   ; default option, nil if none 
  / 
  InitStr                   ; string for initget options 
  kWordStr                  ; string for user's input prompt 
  Inp                       ; user's input 
 ) ;_ closes variable declare 
 (setq 
  kWordStr 
  (substr 
   (apply 
    'strcat                 ; make full string 
    (mapcar                 ; add preceeding / to each string 
     '(lambda (str) (strcat "/" str)) 
 
     InpList 
    ) ;_ closes mapcar 
   ) ;_ closes apply 
   2                        ; remove leading / 
  ) ;_ closes substr 
  InitStr                   ; make string w/spaces, not / 
;;; 以下用于 Visual LISP AutoCAD 
  (vl-string-translate "/" " " kWordStr) 
;;; 结束选项 
 
 
;;; 以下用于非 Visual LISP AutoCAD 
;;;  (substr 
;;;   (apply 
;;;    'strcat 
;;;    (mapcar 
;;;    '(lambda (str) (strcat " " str)) 
;;;     InpList 
;;;    ) ;_ closes mapcar 
;;;   ) ;_ closes apply 
;;;   2 
;;;  ) ;_ closes substr 
;;; 结束选项 
 
 
  PromptStr 
  (strcat 
   (if PromptStr 
    (strcat PromptStr " [") 
    "[" 
   ) ;_ closes if 
   kWordStr 
   "]"                      ; start default indication 
   (if Default 
    (strcat 
     " <" 
     (car (member Default InpList)) ; display default 
     ">: " 
    ) ;_ closes strcat 
    ": " 
   ) ;_ closes if 
  ) ;_ closes strcat 
 ) ;_ closes setq 
 (initget 
  (if Default 0 1)          ; if default allow an 
  InitStr 
 ) ;_ closes initget 
                            ; get input, if null, use default 
 (setq Inp (if (setq Inp (getkword PromptStr)) 
            Inp 
            Default 
           ) ;_ closes if 
 ) ;_ closes setq 
) 
(defun vl-sort-enList (EnList / enl enl1 p1 p2 x1 x rtnList) 
  (foreach enl EnList 
    (progn 
      (setq ang (car enl) 
            enl (cdr enl) 
            ) 
      (setq enl1 
             (mapcar '(LAMBDA (x) 
                        (setq p1 (vlax-curve-getstartpoint x) 
                              p2 (vlax-curve-getendpoint x) 
                        ) 
                        (if (EQUAL ang (/ pi 2) CorJD) 
                          (setq x1 (min (cadr p1) (cadr p2))) 
                          (setq x1 (min (car p1) (car p2))) 
                        ) 
                        (list x1 x) 
                      );LAMBDA 
                     enl 
             );mapcar 
      );setq 
      (setq enl1 (SORT-LIST-UP enl1)) 
      (setq enl1 (mapcar 'cadr enl1) 
            enl1 (cons ang enl1)) 
      (if rtnList 
        (setq rtnList (cons enl1 rtnList)) 
        (setq rtnList (list enl1)) 
        );if 
              
      );progn 
    );foreach 
  rtnList                        
  );defun 
(defun isOn (pt e) 
  (equal (vlax-curve-getclosestpointto e pt) 
     pt 
     CorJD 
  ) 
) 
(defun hbline (ln1 ln2 / tf p0 p00 p1 p2 p3 p4) 
  (setq    p1   (vlax-curve-getstartpoint ln1) 
    p2   (vlax-curve-getendpoint ln1) 
    p3   (vlax-curve-getstartpoint ln2) 
    p4   (vlax-curve-getendpoint ln2) 
    elst (entget ln1) 
  ) 
  (if (or (ison p3 ln1) 
      (ison p4 ln1) 
      (ison p1 ln2) 
      (ison p2 ln2) 
      ) 
    (progn 
      (setq pl (vl-sort    (list p1 p2 p3 p4) 
            '(lambda (e1 e2) 
               (if (equal (car e1) (car e2) CorJD) 
                 (< (cadr e1) (cadr e2)) 
                 (< (car e1) (car e2)) 
               ) 
             ) 
           ) 
      ) 
      (setq elst (subst (cons 10 (car pl)) (assoc 10 elst) elst) 
        elst (subst (cons 11 (last pl)) (assoc 11 elst) elst) 
      ) 
      (entmod elst) 
      (entdel ln2) 
      (setq delcount (1+ delcount)) 
    ) 
  ) 
  (princ) 
) 
(defun hbzhx (/ a ang e e1 el ep oldlst sp ssl delcount) 
  (setq delcount 0) 
      (command ".undo" "g") 
      (setq ssl (sslength ss)) 
      (while (> ssl 0) 
    (setq e      (ssname ss (setq ssl (1- ssl))) 
          sp  (vlax-curve-getstartpoint e) 
          ep  (vlax-curve-getendpoint e) 
          ang (angle sp ep) 
           
    ) 
    (if (>= ang pi) 
      (setq ang (read (rtos (- ang pi) 2 AngJD))) 
      (setq ang (read (rtos ang 2 AngJD))) 
    ) 
    (if (not el) 
      (setq el (list (list ang e))) 
      (if (setq oldlst (assoc ang el)) 
        (setq el (subst (append oldlst (list e)) 
                oldlst 
                el 
             ) 
        ) 
        (setq el (append el (list (list ang e)))) 
      ) 
    ) 
      ) ;while 
  (setq el (vl-sort-enList el)) 
      ;;将直线按角度划分 
      (foreach i (mapcar 'cdr el) 
    (if (> (length i) 1) 
      (progn 
        (while i 
          (setq e1 (car i)) 
          (setq i (cdr i)) 
          (mapcar '(lambda (a) 
             ;(if (and (not (vlax-erased-p e1)) 
                ;  (not (vlax-erased-p a)) 
                ; ) 
               (hbline e1 a) 
            ; ) 
               ) 
              i 
          ) 
          (setq i (VL-REMOVE-IF 'vlax-erased-p i)) 
        ) 
      ) 
    ) 
      ) 
      (command ".undo" "e") 
  delcount 
) 
;;;ssel 为选择集，Condition 为过滤条件，返回两个选择集表，'(s1 s2) 
;;;s1 为ssel 去除过滤条件后剩下元素的选择集，s2 按过滤条件选择的结果 
(defun filter (ssel Condition / s1 s2 m n en enl) 
  (setq n (sslength ssel) 
        m 0 
        s1 (ssadd) 
        s2 (ssadd)) 
  (while (> (setq m (sslength ssel)) 0) 
    (setq en (ssname ssel (1- m)) 
          enl (entget en)) 
    (if (VL-POSITION Condition enl) 
      (progn 
        (ssadd en s2) 
        (ssdel en ssel) 
        ) 
      (progn 
        (ssadd en s1) 
        (ssdel en ssel) 
        ) 
      ) 
    );while 
  (ssunion (list ssel s1)) 
  (list s1 s2) 
  ) 
(defun c:zxhb (/ ByFloor Sel AngJD CorJD LaList delcount t1 t2 t3 t4 t5 t6 t7 t8) 
  (setierr) 
  (setq Alldelcount 0) 
  (setq ByFloor (I:GetInp "\n按层合并直线Floor或按不层合并直线All" 
                         '("Floor" "All") "Floor")) 
  (initget "  " 5) 
  (setq AngJD (getint "\n直线角度的精度<5>:")) 
  ;(princ "\n选择对象：") 
  (setq Sel (ssget '((0 . "line")))) 
  (if (= AngJD "") (setq AngJD 5)) 
  (setq t1 (getvar "Cdate")) 
  (setq CorJD (expt 10.0  (* -1 AngJD))) 
  (setq k (sslength Sel) 
        ki 0) 
  (repeat k 
    (setq en (ssname Sel ki)) 
    (setq La (vlax-get-property (vlax-ename->vla-object en) 'layer)) 
    (if (not LaList) 
      (setq LaList (list La)) 
        (if (not (VL-POSITION La LaList)) 
          (setq LaList (cons La LaList)) 
          );if 
      );if 
    (setq ki (1+ ki)) 
    );repeat k 
  (setq k (length LaList) 
        ki 0) 
  (if (= "Floor" ByFloor) 
  (repeat k 
    (setq ss (cadr (FILTER sel (cons 8 (nth ki LaList))))) 
    (setq Alldelcount (+ Alldelcount (hbzhx))) 
    (setq ki (1+ ki)) 
    ) 
    (setq ss sel 
          Alldelcount (+ Alldelcount (hbzhx))) 
    ) 
  (princ (strcat "\n滤除直线共计" (itoa Alldelcount) "条！")) 
      (setq t2 (getvar "Cdate")) 
    (setq t3 t1) 
    (setq t4 (fix (* 100 t3)) 
          t5 (- (fix (* 10000 t3)) (* t4 100)) 
          t6 (-  (* 1000000 t3) (* t5 100) (* t4 10000)) 
          t7 (+ (* t4 3600) (* t5 60) t6) 
          ) 
     (setq t3 t2) 
    (setq t4 (fix (* 100 t3)) 
          t5 (- (fix (* 10000 t3)) (* t4 100)) 
          t6 (-  (* 1000000 t3) (* t5 100) (* t4 10000)) 
          t8 (+ (* t4 3600) (* t5 60) t6) 
          ) 
    
    
    (princ "\n用时") 
    (princ (- t8 t7)) 
    (princ "秒") 
  (reerr) 
 
  (princ) 
  )

zh_6531394 · 发表于 2005-6-16 17:25:52

命令:
HBZHX
选择对象: 指定对角点: 找到 2 个

选择对象:

Error: no function definition: ACET-UI-PROGRESS.

它山之石 · 发表于 2005-6-17 09:45:47

看看商业软件《探索者2.7》的处理程序。当然如果没有安装TSSD的话，有许多函数未提供定义，实际上程序不会运行。俺贴出来主要是让大家看看在算法上有什么异同。俺也没进行测试，因为俺不会象lijiao那样遇到很多的重线。速度一般用也没有什么问题。
[php]
(@lsp "myfan")
(defun rduplin (la prinf / mm mma mx 2pi la1 stl st1
st2 ss si smx e n n1 n2 nr1 a0 a1
a2 p1 p2 l l1 ll ll1 ll2 ll3 lle len
len1 nr tf rdang rdline
 )
 (defun rdline (l2 / e ln1 ll1 ll2 ll3 ll4 lle len len1)
(setq ll (car l2)
 p1 (car ll)
 p2 (cadr ll)
 a1 (angle p1 p2)
 p3 (polar p1 (+ _pi2 a1) mx)
 nr (+ nr (length l2))
) ;_ 结束setq
(foreach ll l2
 (setq e (last ll)
 ll1 (cons (list (&Beg (car ll) p1 p3) e) ll1)
 ll1 (cons (list (&Beg (cadr ll) p1 p3) e) ll1)
 lle (cons e lle)
 ) ;_ 结束setq
) ;_ 结束foreach
(setq ll1 (@ran3 ll1)
 ln1 (+ mx (caar ll1))
) ;_ 结束setq
(foreach ll ll1
 (setq ln (car ll)
 e (cadr ll)
 ) ;_ 结束setq
 (if ll2
(progn (setq ll3 (member e ll2)
 ll2 (if ll3
 (append (cdr ll3) (cdr (member e (reverse ll2))))
 (cons e ll2)
 ) ;_ 结束if
 ) ;_ 结束setq
 (if (not ll2)
 (setq ll4 (cons (cons (polar p1 a1 ln) p2) ll4)
 ln1 ln
 ) ;_ 结束setq
 ) ;_ 结束if
) ;_ 结束progn
(progn (if (equal ln1 ln mm)
 (setq ll4 (cdr ll4))
 (setq p2 (polar p1 a1 ln))
 ) ;_ 结束if
 (setq ll2 (cdr ll))
) ;_ 结束progn
 ) ;_ 结束if
) ;_ 结束foreach
(if (> (setq len (length ll4)
 len1 (length lle)
 ) ;_ 结束setq
 len
) ;_ 结束>
 (progn (repeat (- len1 len)
 (setq e (car lle)
 lle (cdr lle)
 ) ;_ 结束setq
 (entdel e)
 ) ;_ 结束repeat
 (foreach ll ll4
 (setq e (car lle)
 lle (cdr lle)
 e (entget e)
 e (subst (cons 10 (car ll)) (assoc 10 e) e)
 e (subst (cons 11 (cdr ll)) (assoc 11 e) e)
 ) ;_ 结束setq
 (entmod e)
 ) ;_ 结束foreach
 ) ;_ 结束progn
) ;_ 结束if
(setq nr (- nr len))
(if (> (- nr n2) 40)
 (progn (setq n2 nr) (prinf (strcat st2 (itoa nr))))
) ;_ 结束if
 ) ;_ 结束defun
 (defun rdang (l0 / e1 a1 p1 p2 p3 ln l1 l2 ll ll1)
(setq ll (car l0)
 p1 (car ll)
 p2 (cadr ll)
 l1 (list (list 0. ll))
) ;_ 结束setq
(foreach ll (cdr l0)
 (setq ln (&Beg (car ll) p1 p2)
 l2 l1
 ) ;_ 结束setq
 (while (and (setq ll1 (car l2)) (not (equal ln (car ll1) mm)))
(setq l2 (cdr l2))
 ) ;_ 结束while
 (setq l1 (if ll1
 (subst (append ll1 (list ll)) ll1 l1)
 (cons (list ln ll) l1)
 ) ;_ 结束if
 ) ;_ 结束setq
) ;_ 结束foreach
(foreach l2 l1
 (setq l2 (cdr l2))
 (if (cdr l2)
(rdline l2)
 ) ;_ 结束if
) ;_ 结束foreach
 ) ;_ 结束defun
 (setq mx 1e9
mm (* 0.01 (cadr (&Plcen t)))
mma 1e-4
2pi (* pi 2)
 ) ;_ 结束setq
 (setq stl (strcat "'" la "'层")
la (cons 8 la)
ss (ssget "x" (list '(0 . "line") la))
 ) ;_ 结束setq
 (if ss
(progn (setq st1 (strcat "\r已搜索到" stl "直线 ")
 smx (sslength ss)
 st2 (strcat "\r已消去" stl "直线 ")
 n 0
 n1 0
 n2 0
 ) ;_ 结束setq
 (prinf "\n")
 (while (< n smx)
 (setq e (ssname ss n)
 n (1+ n)
 p1 (&Gpts e 10)
 p2 (&Gpts 11)
 ) ;_ 结束setq
 (if (equal p1 p2 mm)
 (progn (entdel e) (setq n1 (1+ n1)))
 (setq ll1 (list (list p1 p2 e))
 a1 (angle p1 p2)
 a1 (cond ((or (equal a1 pi mma) (equal a1 2pi mma)) 0)
 ((< a1 pi) a1)
 ((- a1 pi))
 ) ;_ 结束cond
 a1 (rtos a1 2 4)
 la1 (list a1
 (&Gpts 8)
 (&Gpts 62)
 (&Gpts 6)
 (&Gpts 48)
 (&Gpts 330)
 ) ;_ 结束list
 ll (assoc la1 l1)
 l1 (if ll
 (subst (append ll ll1) ll l1)
 (cons (cons la1 ll1) l1)
 ) ;_ 结束if
 ) ;_ 结束setq
 ) ;_ 结束if
 (if (= 127 (logand 127 n))
 (prinf (strcat st1 (itoa n)))
 ) ;_ 结束if
 ) ;_ 结束while
 (prinf (strcat st1
 (itoa n)
 (if (zerop n1)
 ""
 (strcat ". 已消去超短线 " (itoa n1))
 ) ;_ 结束if
 "\n"
 ) ;_ 结束strcat
 ) ;_ 结束prinf
 (setq nr 0)
 (foreach ll l1
 (setq ll (cdr ll))
 (if (cdr ll)
 (rdang ll)
 ) ;_ 结束if
 ) ;_ 结束foreach
 (prinf (strcat st2 (itoa nr) " 还剩 " (itoa (- n n1 nr))))
) ;_ 结束progn
 ) ;_ 结束if
 (setq n 0
n1 0
nr 0
l1 nil
st1 (strcat "\r已搜索到" stl "圆弧 ")
st2 (strcat "\r已消去" stl "圆弧 ")
 ) ;_ 结束setq
 (prinf "\n")
 (setq ss (ssget "x" (list '(0 . "circle") la)))
 (if ss
(progn (setq smx (sslength ss))
 (while (< n smx)
 (setq e (ssname ss n)
 n (1+ n)
 ll (list (list (&Gpts e 40) (&Gpts 10) (&Gpts 8)))
 ) ;_ 结束setq
 (if (member ll l1)
 (progn (setq nr (1+ nr)) (entdel e))
 (setq l1 (cons ll l1))
 ) ;_ 结束if
 ) ;_ 结束while
) ;_ 结束progn
 ) ;_ 结束if
 (setq ss (ssget "x" (list '(0 . "arc") la)))
 (if ss
(progn
 (setq smx (sslength ss)
 si 0
 ) ;_ 结束setq
 (while (< si smx)
(setq e (ssname ss si)
 si (1+ si)
 n (1+ n)
 a1 (&Gpts e 50)
 a2 (&Gpts 51)
) ;_ 结束setq
(if (equal a1 a2 mma)
 (progn (entdel e) (setq n1 (1+ n1)))
 (progn
 (setq ll (list (&Gpts 40)
 (&Gpts 10)
 (&Gpts 8)
 (&Gpts 62)
 (&Gpts 6)
 (&Gpts 48)
 (&Gpts 330)
 ) ;_ 结束list
 ll1 (list (list a1 a2 e))
 n2 0
 ) ;_ 结束setq
 (if l1
 (while
(and (setq l (nth n2 l1)) (not (equal ll (car l) mm)))
 (setq n2 (1+ n2))
 ) ;_ 结束while
 (setq l nil)
 ) ;_ 结束if
 (if l
 (if (cdr l)
(setq l1 (subst (append l ll1) l l1))
(progn (setq nr (1+ nr)) (entdel e))
 ) ;_ 结束if
 (setq l1 (cons (cons ll ll1) l1))
 ) ;_ 结束if
 ) ;_ 结束progn
) ;_ 结束if
(if (= 127 (logand 127 n))
 (prinf (strcat st1 (itoa n)))
) ;_ 结束if
 ) ;_ 结束while
 (prinf (strcat st1
 (itoa n)
 (if (zerop n1)
 ""
 (strcat ". 已消去超短弧 " (itoa n1))
 ) ;_ 结束if
 "\n"
 ) ;_ 结束strcat
 ) ;_ 结束prinf
 (setq n2 0)
 (foreach l l1
(setq p1 (car l)
 l (cdr l)
) ;_ 结束setq
(if (cdr l)
 (progn (setq ll nil
 lle nil
 nr (+ nr (length l))
 tf nil
 ) ;_ 结束setq
 (foreach x l
 (setq a1 (car x)
 a2 (cadr x)
 e (last x)
 lle (cons e lle)
 ) ;_ 结束setq
 (if (< a2 a1)
 (setq ll (cons (cons a1 e) (cons (cons 2pi e) ll))
 a1 0
 tf T
 ) ;_ 结束setq
 ) ;_ 结束if
 (setq ll (cons (cons a1 e) (cons (cons a2 e) ll)))
 ) ;_ 结束foreach
 (setq ll (@ran3 ll)
 ll3 nil
 a1 -1
 ) ;_ 结束setq
 (foreach x ll
 (setq a2 (car x)
 e (cdr x)
 ) ;_ 结束setq
 (if ll2
 (progn (setq l (member e ll2)
 ll2 (if l
(append (cdr l)
(cdr (member e (reverse ll2)))
) ;_ 结束append
(cons e ll2)
 ) ;_ 结束if
 ) ;_ 结束setq
 (if (not ll2)
 (setq ll3 (cons (cons a0 a2) ll3)
 a1 a2
 ) ;_ 结束setq
 ) ;_ 结束if
 ) ;_ 结束progn
 (progn (if (equal a1 a2 mma)
 (setq ll3 (cdr ll3))
 (setq a0 a2
 a1 a2
 ) ;_ 结束setq
 ) ;_ 结束if
 (setq ll2 (list e))
 ) ;_ 结束progn
 ) ;_ 结束if
 ) ;_ 结束foreach
 (setq len (length ll3)
 len1 (length lle)
 ) ;_ 结束setq
 (if tf
 (if (= 1 len)
 (progn (foreach e lle (entdel e))
 (entmake (list '(0 . "circle")
 (cons 8 (last p1))
 (cons 10 (cadr p1))
 (cons 40 (car p1))
 ) ;_ 结束list
 ) ;_ 结束entmake
 (setq len1 len)
 ) ;_ 结束progn
 (setq len (1- len)
 l (car ll3)
 ll3 (reverse (cdr ll3))
 ll3 (cons (cons (car l) (cdar ll3)) (cdr ll3))
 ) ;_ 结束setq
 ) ;_ 结束if
 ) ;_ 结束if
 (if (> len1 len)
 (progn (repeat (- len1 len)
 (setq e (car lle)
 lle (cdr lle)
 ) ;_ 结束setq
 (entdel e)
 ) ;_ 结束repeat
 (foreach ll ll3
 (setq e (car lle)
 lle (cdr lle)
 e (entget e)
 e (subst (cons 50 (car ll)) (assoc 50 e) e)
 e (subst (cons 51 (cdr ll)) (assoc 51 e) e)
 ) ;_ 结束setq
 (entmod e)
 ) ;_ 结束foreach
 ) ;_ 结束progn
 ) ;_ 结束if
 (setq nr (- nr len))
 (if (> (- nr n2) 40)
 (progn (setq n2 nr) (prinf (strcat st2 (itoa nr))))
 ) ;_ 结束if
 ) ;_ 结束progn
) ;_ 结束if
 ) ;_ 结束foreach
) ;_ 结束progn
 ) ;_ 结束if
 (if (> n 0)
(prinf (strcat st2 (itoa nr) " 还剩 " (itoa (- n nr n1))))
 ) ;_ 结束if
 (redraw)
) ;_ 结束defun
(setfunhelp "c:XCHCHX" "tssd.hlp" "XCHCHX")
(defun c:XCHCHX (/ e)
 (if (and (>= (&Swap) 0)
 (setq
 e (&Ints "\n选取要进行重线清理图层上的任何一个实体<退出>: ")
 ) ;_ 结束setq
 ) ;_ 结束and
(rduplin (&Gpts 8) princ)
 ) ;_ 结束if
 (&Gscl)
) ;_ 结束defun
(setfunhelp "c:XCHZHX" "tssd.hlp" "XCHZHX")
(defun c:XCHZHX ()
 (if (>= (&Swap) 0)
(rduplin (&End "轴线") princ)
 ) ;_ 结束if
 (&Gscl)
) ;_ 结束defun
(setfunhelp "c:XCHLX" "tssd.hlp" "XCHLX")
(defun c:XCHLX ()
 (if (>= (&Swap) 0)
(progn (rduplin (&End "主梁") princ)
 (rduplin (&End "次梁") princ)
) ;_ 结束progn
 ) ;_ 结束if
 (&Gscl)
) ;_ 结束defun
[/php]

温柔女神 · 发表于 2005-6-17 17:12:21

最初由 liuyj 发布
[B]

你没安装express for 2004 [/B]

我使用是也出错
express for 2004是什么软件啊
我的是CAD2002

账号		自动登录	找回密码
密码			立即注册