请高手帮修改一个程序

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.gif6 d' v" e( k( \( J" M. |
有没有中间使用变量得说明？做什么用得？

没有　这个程序用来删除多余的图元。程序特点，可以删除完全重合的直线、多段线、光滑曲线（程序中设置了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

?- ]/ k4 a1 E- `& Z. g. `
(defun dxg (code ele)) e6 N4 d- B1 a8 \. U
(cdr (assoc code (entget ele)))2 S4 A( O" k' [
)
9 H% E8 [2 w9 I3 t4 f
4 r0 x% S# C0 S8 F
* v& z9 m8 t" _
(defun vpt (a b c)- ~- Z! J' y5 _( @3 ]; k% u! V
(equal0 L7 M5 c6 x2 r2 E/ ^/ C7 V0 o
(if (caddr a) a (reverse (cons 0.0 (reverse a)))); ]% _2 V W6 s
(if (caddr b) b (reverse (cons 0.0 (reverse b))))% h; d* N. V( x4 [7 L3 X* _% r
(expt 0.1 c)6 \3 ]4 J4 p& B( V# Q1 I, u
)
): x+ Q0 F4 K4 |/ L K8 \4 q7 g
- k G, f' z# @* p8 v0 ^/ L _% L
;;; =========== for Test only =========================================9 [0 I9 i4 J4 s- u: I+ J
;;; 删除线段内的短线
+ o; H6 Q3 e4 v$ V* R1 Y% }6 D
;; ssen = Line Selection+ t! J6 Z# y7 E3 H
(setq nn (sslength ssen))* O% w+ \+ p- Z6 d& J" A
(cond
b# T: W0 c- N. p/ f
((< nn 2) nil) ; Nothing to do
/ ~- l y# B, J1 Q$ ?9 M
(T2 f6 M$ w6 n, i/ E2 v: R5 c/ R
(princ "\nProceeding with Line ....."
, A# f$ C8 Y/ x5 Y: T
(while (setq ee (ssname ssen (setq nn (1- nn)))) " Z7 H7 z0 \, l# k! J# I
(cond
7 p9 H9 L8 }- M
((null (entget ee))) ; bypass2 @7 F- c( _7 v4 ?3 b0 f
(T
. t% N/ ^7 L( I3 w' F$ i/ T! v$ Y
(setq p1 (dxg 10 ee)( K+ o2 {' G8 t1 C G
p2 (dxg 11 ee)+ D* I- R/ R2 E
v1 (angle p1 p2)9 P0 u" j! Z- `4 A' w0 X8 G
e1d (cdddr (cddr (entget ee)))6 W2 Y1 l! D6 ^
sc (ssget "f" (list p1 p2) '((0 . "LINE")
9 M& G( d, k) R3 k. q8 \
sum (if sc (sslength sc))1 q) ]* |6 F8 w( o/ y
)
& Z9 g8 @ g* }+ g7 ^5 g
(while (and (entget ee) (> sum 0))2 w9 L# x. |1 s
(setq e1 (ssname sc (setq sum (1- sum))))5 `4 C3 l. `5 T& z/ w
(cond
% ` U, Z" [: {% e5 m: N; o1 L- M
((eq e1 ee) nil) ; Itself
+ `6 B. p% T8 c; \& j" x Q
((equal (cdddr (cdddr (entget e1))) e1d); l: H/ U2 B3 C1 z, B8 J
(entdel e1)
/ n: t& [# x) G V* ~0 E
)% T8 m- N+ _* x5 y& M7 d6 f
(T
/ h! |$ J7 c/ Q G. D
(setq p3 (dxg 10 e1)6 e) ~2 b# O5 s0 S$ W, q
p4 (dxg 11 e1)8 l6 T2 W6 z$ k* b+ s
v2 (if (vpt p1 p3 5)0 I8 E) G# Q3 {/ g$ @
(angle p2 p3)1 s- p7 ?# F f( w% |+ D6 f
(angle p1 p3)
- ^; `' _: H2 e. _: }$ f
)
! Z& {$ V4 e# P5 I) q: C3 h7 C+ L( `" A
)2 L& l" u, P) h
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
* l! I& M* h0 h- {/ l+ [: V
(if (< (distance p3 p4) (distance p1 p2))9 Y4 f8 o4 J" [2 g7 i
(entdel e1)
4 ~% w, r) r% B' d5 R
(entdel ee)
8 m% o: Y& S9 q/ |
). k' p5 [8 I1 G" `' e
)# i. k/ |+ h5 n# B# |5 u
)9 o. ^: v6 s. U3 ^
)0 G! z' [* r# M
)6 u/ o$ u7 ~8 m- R6 m' d% C- x' t$ Q
)/ k! o" R9 x' U6 y5 ~$ n, h( n8 w! o/ \) R
)
2 Y) K2 N3 p3 @, J
)! V! H% T! m) I# K$ @6 m+ Q$ s% E
)3 N9 | n6 g. j, }. {
)
g1 y4 M3 }) k3 X1 `
% o$ C* ]* ?6 w# X

复制代码

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

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

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

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

通知

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

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

评分

评分

评分

浏览过的版块