请高手帮修改一个程序

zedcar · 发表于 2008-11-26 09:33:57

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

　　　在网上找的一个删除重复图元的ＬＩＳＰ程序　加载使用后发现对重复线段的删除有时候无效　而且线段内部的线段无法删除　就是说如果一条线段长１００一条长５０　使用这个删除不掉！！请高手帮忙修改下！！
　以下是程序原文：（附件内容是程序源文件）
(defun c:ere()
  (setq m0 (getpoint "\n左下角："))
  (setq m1 (getpoint "\n右上角："))
  (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)
   (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)
      (setq j (- i 1))
      (setq b (ssname a (setq i (1- i)))) ;(setq b (ssname a 1))
      (setq c (entget b))
      (setq d (cdr (assoc 0 c)))
      (while (> j 0)
      (setq b1 (ssname a (setq j (1- j))))
      (setq c1 (entget b1))
      (setq d1 (cdr (assoc 0 c1)))
      (if (= d d1)
         (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))
                     (= (rtos (caddr (assoc 11 c)) 2 4)(rtos (caddr (assoc 11 c1)) 2 4))
               )(command "erase" b1 "")
            )
            (if (= d "INSERT")
            (if (and (equal (assoc 2 c) (assoc 2 c1))
                     (= (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")
               (progn
                  (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                  (while (and e e1)
                  (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))
                           (/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
                     (if (not e1) (command "erase" b1 "")(if (not e)
                        (progn (command "erase" b "")(setq b b1 b1 nil))))
               ) ) ) )
               (if (= d "SPLINE")
                  (progn
                  (setq e (cddddr c) e1 (cddddr c1) e (cddddr e) e1 (cddddr e1))
                  (while (and e e1)
                     (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))(/= (rtos (caddr f) 2 4)(rtos (caddr f1) 2 4)))(setq e1 nil)
                        (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))
                        )(command "erase" b1 "")
                  )
                  (if (= d "CIRCLE")
                     (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 (cdr (assoc 40 c)) 2 4)(rtos (cdr (assoc 40 c1)) 2 4))
                        )(command "erase" b1 "")
   ) ) ) ) ) ) ) ) ) )
   (setq m3 (polar m3 1.5708 50.0) y2 (+ y2 50.0))
)
(setq m2 (polar m2 0.0 50.0) x2 (+ x2 50.0))
  )
  (princ)
)
(princ "\n\"ere\"启动")

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

maoyangmy · 发表于 2008-11-26 11:05:42

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

zedcar · 发表于 2008-11-26 12:40:25

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

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

ljm68 · 发表于 2008-12-6 15:17:15

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

SunVei · 发表于 2008-12-6 22:42:04

, C0 U ~% v) `
(defun dxg (code ele)
) Z( V* D5 `0 ]( B4 P" w9 h! A
(cdr (assoc code (entget ele)))$ U. l3 O" \9 ^- @+ U5 [( S) [
)
5 a( b. \0 |. y( ~* P8 ^
7 c+ \: y3 E+ S2 C, _
; b) z* F! m. c3 Z; P: I
(defun vpt (a b c), o! D; P2 I( S1 s
(equal+ ^) Z5 z. U" ^
(if (caddr a) a (reverse (cons 0.0 (reverse a)))): O( u; F; @$ A/ B. s6 \4 M
(if (caddr b) b (reverse (cons 0.0 (reverse b))))" I1 _& f1 Q! s6 l4 D8 m* ^
(expt 0.1 c)( h5 l6 H& n- s1 I$ ^7 v. N3 o' T6 U
)- J" V2 R7 ^8 u* c
)
( F) B4 H* u5 M
, g" N# o1 |/ P7 z& m0 ^7 @- }
;;; =========== for Test only =========================================
+ Y r1 O) S! x
;;; 删除线段内的短线
( `( a) Y) F" w7 d4 j* u- |* Q
;; ssen = Line Selection
# @& F1 K5 t% e5 Q% S& M
(setq nn (sslength ssen))
8 _9 u, z$ q C$ D! E( I6 ]
(cond
- S+ S8 F' P/ {" ^6 p5 J, @
((< nn 2) nil) ; Nothing to do% [; h" |) |8 o+ h1 x- T
(T
: F5 n, A9 e; Y( P2 T
(princ "\nProceeding with Line ....."' C$ |3 k D( a0 B
(while (setq ee (ssname ssen (setq nn (1- nn)))) & b. e" N0 _' B. e" J) V
(cond
$ @- \ Y/ K9 \; F9 l* t4 t! l4 ^
((null (entget ee))) ; bypass
* U8 y' t/ Y+ X/ ~9 z
(T
5 f" U# \( V0 A- u5 Y$ q3 m
(setq p1 (dxg 10 ee)
$ W4 L5 E x; g- `. v" w
p2 (dxg 11 ee)+ x6 l, u/ v8 s+ P1 C
v1 (angle p1 p2)
2 H1 c; N: j. J/ z( N0 Z1 @
e1d (cdddr (cddr (entget ee)))& D; C0 Y, n* e4 t0 f
sc (ssget "f" (list p1 p2) '((0 . "LINE")6 x3 `5 V- P. d* e& d" J
sum (if sc (sslength sc))" s3 |2 l% d$ Q- z" {, T
)' T. ~ H v5 Y
(while (and (entget ee) (> sum 0))- z( @5 V0 l* m% c$ {) S3 A
(setq e1 (ssname sc (setq sum (1- sum))))
5 W: g2 E7 c( P( O- [" v9 _/ G4 Q
(cond/ j9 d) a/ _: C% B: D4 E; {+ }
((eq e1 ee) nil) ; Itself* c7 Y* y+ m/ h4 M8 I0 y8 G7 k
((equal (cdddr (cdddr (entget e1))) e1d)" `) C3 ^. S( v% \, w' @
(entdel e1)
& K; _9 O/ L/ ^
)7 m; U7 F9 ~, @0 n6 r
(T
$ l! H* s5 o) S3 z0 G' O
(setq p3 (dxg 10 e1)
, v" f9 V0 b9 e1 X
p4 (dxg 11 e1)
$ K# b3 ~+ S: i; Z% V; }7 X
v2 (if (vpt p1 p3 5)
) V; c4 |3 P. f) f2 l
(angle p2 p3)
: W+ F7 X( q# r' i: W0 ]) Q4 T
(angle p1 p3)8 C9 O) K5 o. m! N% }, u/ I" ?$ Y
)
' e3 k3 y; T* r9 _
)& z! w+ s7 Y. T9 t
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
$ C, x& D1 ^- N3 y3 Z2 }
(if (< (distance p3 p4) (distance p1 p2))
) j* x+ D2 B6 W- s* j- }
(entdel e1)
! z0 q8 c- c, X- L
(entdel ee)
2 Z% c) q0 F# U
)% a1 q% F5 a. [% L" d; f% F6 z* D
)
3 ? j9 s- I% u$ t
)
5 q' M8 M0 l$ j
)
O5 h8 R4 Z2 B6 Z0 @: C) d% B2 q; Y
)
7 b5 B9 w* Z9 ~. r
)
" \: N' {% ?$ X' z5 }9 x
)
: K7 j) ` U9 T0 e1 o7 G" j5 Q) P
) z" h8 O4 C/ W6 K3 q
)
; k1 x' A: y* w, P( Q0 s
)
* Y5 c5 s# ~% {* m8 h1 Y, G! O# L
( Z9 c( T4 Q2 a7 s( Q

复制代码

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

cai813 · 发表于 2008-12-7 09:59:37

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

		自动登录	找回密码
密码			注册

通知

[求助] 请高手帮修改一个程序

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

评分

评分

评分

浏览过的版块