请高手帮修改一个程序

zedcar

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
  (setq m0 (getpoint "\n左下角："))
$ S; _- R$ q/ y1 L( r  (setq m1 (getpoint "\n右上角："))
) Q) R8 K9 ?, P4 ~  (setq x0 (car m0) x1 (car m1) y0 (cadr m0) y1 (cadr m1) m2 m0 x2 x0 y2 y0)
  (while (< x2 x1)
    (setq y2 y0 m3 m2)
    (while (< y2 y1)
. x) I' x7 |" p$ J3 X; i      (setq m4 (polar m3 0.785398 70.72))
      (setq a (ssget "_C" m3 m4))
      (if (not a)(setq i 0)(setq i (sslength a)))
      (while (> i 1)
, D0 Z. _& U7 \) a$ m        (setq j (- i 1))
        (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
5 ]$ A4 G4 o5 B" u# Z4 W        (setq c (entget b))
: B7 \6 l: C' l        (setq d (cdr (assoc 0 c)))
        (while (> j 0)
& p( v/ `( C- K, A4 H9 h          (setq b1 (ssname a (setq j (1- j))))
          (setq c1 (entget b1))
  X4 G& c2 f5 n& p2 x! q' [          (setq d1 (cdr (assoc 0 c1)))
          (if (= d d1)
7 e# A3 f* l1 G) U; Z5 I1 i            (if (= d "LINE")
              (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                       (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                       (= (rtos (cadr (assoc 11 c)) 2 4)(rtos (cadr (assoc 11 c1)) 2 4))
4 X  ?! F4 H  e0 `2 j, K                       (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
, m8 r6 P' a7 d: h5 A0 \                  )(command "erase" b1 "")
! W6 B9 g+ s# }. l  ?+ I              )
              (if (= d "INSERT")
- B2 z1 [0 h; B. I0 u! Q' a                (if (and (equal (assoc 2 c) (assoc 2 c1))
- P4 ~- I7 M1 |+ L; e                         (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                         (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                    )(command "erase" b1 "")
                )
                (if (= d "LWPOLYLINE")
& R3 z; a+ k5 K9 ^% g/ j! S                  (progn
, e$ y8 M/ R7 g) }# e& r- \7 Q                    (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
* |: N$ P# Q1 y# Z% x5 v) K9 H7 W                    (while (and e e1)
' n2 u; I" D  F" W                      (progn
                      (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
                      (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
                      (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                      (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))
' \7 U5 W! f  D) }; Z                              (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
4 V# D! J8 {' c* T3 {                        (if (not e1) (command "erase" b1 "")(if (not e)
                           (progn (command "erase" b "")(setq b b1 b1 nil))))
                  ) ) ) )         
. N) ]9 N9 W) K4 G                  (if (= d "SPLINE")
                    (progn
/ i# O, r( p, E4 o                      (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                      (while (and e e1)
                        (progn
: x; s$ n6 L; o% w2 b- d                          (setq f (car e) f1 (car e1) e (cdr e) e1 (cdr e1))
                          (while (and e (/= (car f) 10))(setq f (car e) e (cdr e)))
+ p' |. s) |" A: V* s                          (while (and e1 (/= (car f1) 10))(setq f1 (car e1) e1 (cdr e1)))
                          (if (or (/= (rtos (cadr f) 2 4)(rtos (cadr f1) 2 4))(/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
, ?* u! \9 z  p, W2 K                            (if (not e1 ) (command "erase" b1 "")(if (not e)(progn (command "erase" b "")(setq b b1 b1 nil))))
                    ) ) ) )         
                    (if (= d "TEXT")
                      (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
                               (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
! E9 p' J( r- Q! V9 c                          )(command "erase" b1 "")
7 J# Z8 C/ S1 k- t; f7 s                      )
                      (if (= d "CIRCLE")
; k, x; G/ k% {% x6 L$ o, l                        (if (and (= (rtos (cadr (assoc 10 c)) 2 4)(rtos (cadr (assoc 10 c1)) 2 4))
8 `) c, _' B  f3 [                                 (= (rtos (caddr (assoc 10 c)) 2 4)(rtos (caddr (assoc 10 c1)) 2 4))
                                 (= (rtos (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
  G8 w" L9 k: N6 M                            )(command "erase" b1 "")
: S& B5 R% k5 p! j      ) ) ) ) ) ) ) ) ) )
      (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
. L+ n9 l" g3 _  x$ Y% [    )
    (setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
; k& U7 s8 ?  _  g4 A)
(princ "\n\"ere\"启动")

[ 本帖最后由 zedcar 于 2008-11-26 09:35 编辑 ]

maoyangmy

有没有中间使用变量得说明？做什么用得？

zedcar

原帖由 maoyangmy 于 2008-11-26 11:05 发表 http://www.3dportal.cn/discuz/images/common/back.gif
有没有中间使用变量得说明？做什么用得？

没有　这个程序用来删除多余的图元。程序特点，可以删除完全重合的直线、多段线、光滑曲线（程序中设置了4位小数，当坐标数值四舍五入精确到4位小数时认为重合），删除位置重合的文字，删除位置和半径相同的圆，删除位置和块名相同的块。

ljm68

给你一个思路：
- F$ m' A, F; {0 e    处理"LINE"时，增加一个判定函数，用于首先判定直线L1的两个端点是否在直线L2上面；若在，再判定直线L1的两个端点是否在直线L2的两个端点以内，则返回直线L1，否则返回直线L2。
    判定直线L1的两个端点是否在直线L2上面：
       可以逐点计算直线L1的两个端点到直线L2的距离是否小余你的精度要求，若小余，则判定为该点在直线L2上，否则，该点不在直线L2上。

SunVei

1.    
   8 }8 s; z+ N9 G" [4 \
2.     (defun dxg (code ele)
   ; c. B! T4 l+ f+ {
3.       (cdr (assoc code (entget ele)))
   
4.     )
   9 H, t, @; v& V; {" z3 x6 ?) a
5.       
   
6. 
   
7.     (defun vpt (a b c)
   
8.        (equal
   
9.          (if (caddr a) a (reverse (cons 0.0 (reverse a))))
   5 ~. j# ^9 [! w% e, {) P
10.          (if (caddr b) b (reverse (cons 0.0 (reverse b))))
    
11.          (expt 0.1 c)
    & `2 O+ r8 ]' _# F: A! Z: \7 P
12.        )
    ! c' M$ u/ a2 L: P1 Y" [: d
13.     )
    ' k$ I$ V, x$ _* R
14.    
    ! s* z+ y0 \1 _7 d: J
15. ;;; =========== for Test only =========================================
    
16. ;;; 删除线段内的短线
      u2 C$ O, h4 n# h
17. ;; ssen = Line Selection
    
18. (setq nn (sslength ssen))
    
19. (cond
    
20.   ((< nn 2) nil)                        ; Nothing to do
    
21.   (T
    ) k; W2 w! J1 }9 u9 B7 w' `
22.    (princ "\nProceeding with Line ....."
    
23.    (while (setq ee (ssname ssen (setq nn (1- nn))))
    8 H6 E. d( p' ^6 }0 H  ?. y
24.      (cond
    - E- a- `6 [0 E8 P$ k8 J
25.        ((null (entget ee)))                ; bypass
    # B3 _' k7 X# T/ E& V# b  ]
26.        (T
    
27.         (setq p1  (dxg 10 ee)
    
28.               p2  (dxg 11 ee)
    
29.               v1  (angle p1 p2)
    , q9 o" T7 S; B; ?: O- {2 I9 G1 N) T
30.               e1d (cdddr (cddr (entget ee)))
    
31.               sc  (ssget "f" (list p1 p2) '((0 . "LINE")
    
32.               sum (if sc (sslength sc))
    ( i. P) E+ x& @
33.         )
    ) @( G/ Q2 S4 U7 I* ]/ V
34.         (while (and (entget ee) (> sum 0))
    ' N0 ]8 G9 C" q3 D! c
35.           (setq e1 (ssname sc (setq sum (1- sum))))
    
36.           (cond
    
37.             ((eq e1 ee) nil)                ; Itself
    
38.             ((equal (cdddr (cdddr (entget e1))) e1d)
    ) {. q1 M. s2 }5 X/ q" W' C8 {
39.              (entdel e1)
      q' P& [$ R; A7 ]! r7 l/ ~* S
40.             )
    $ i8 M, l9 S" ~; `
41.             (T
    * w/ t! R' P6 g9 e, n. `
42.              (setq p3 (dxg 10 e1)
    % _2 c# `# a: g5 l6 q1 D9 I
43.                    p4 (dxg 11 e1)
    
44.                    v2 (if (vpt p1 p3 5)
    
45.                         (angle p2 p3)
    8 K8 S3 q# S2 Q" N
46.                         (angle p1 p3)
    % U# c) M% @) G* @# ^$ Y( ~5 i
47.                       )
    
48.              )
    
49.              (if (< (rem (abs (- v1 v2)) pi) 0.0001)
    : C/ t& Q. y& j$ T! |) I. f6 C8 I
50.                (if (< (distance p3 p4) (distance p1 p2))
    . C& [7 f% m6 s3 P1 ~+ }
51.                  (entdel e1)
    1 a: g7 Q0 n9 _2 c, o( S/ P) L& Q
52.                  (entdel ee)
    + b9 p& V9 \0 D* Y! t
53.                )
    ( e2 r- I! }% B" A  \+ s
54.              )
    2 B' W2 n; e3 G
55.             )
    
56.           )
    ( Z* U9 n* S: G
57.         )
    1 k. J9 Z6 M. k# B
58.        )
    
59.      )
    
60.    )
    : F4 p, S8 q( G/ }+ K: T; [
61.   )
    ; {: }* v# K$ J
62. )
    
63. 
    ( r) A( v+ B& Z+ W2 l2 P. c5 P; [3 r

复制代码

[ 本帖最后由 SunVei 于 2008-12-6 23:24 编辑 ]

cai813

我认为对有利于促进论坛的发展,同时也激励会员多参与.但对于管理人员应该考虑工作需要,不收取流量.