请高手帮修改一个程序

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( q+ [1 R! B3 A0 s p' I) I
有没有中间使用变量得说明？做什么用得？

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

7 Y# z- _; J/ k0 v/ r+ t O
(defun dxg (code ele), f; a" ~6 q& c) J* K
(cdr (assoc code (entget ele)))
8 @+ x+ O- U+ t( k+ d8 ?
), x. P8 g ^4 c4 A. _# X P. k5 {0 ^; M
1 h/ ~9 ~2 [6 x+ W3 Z5 G& s
! N8 L# v3 \. [/ E" `% `* y! o
(defun vpt (a b c)* E- c5 d: {: Z( m/ ?; y. m5 E E
(equal, V& C% m- j Z, t) ?: L6 P
(if (caddr a) a (reverse (cons 0.0 (reverse a))))
8 @, f& f# }* k( V1 z
(if (caddr b) b (reverse (cons 0.0 (reverse b))))2 j# l) G0 w- p8 w5 A& {
(expt 0.1 c)
% U0 J- k2 r; w, v( _6 ~. D
); i: T1 {9 |, \
) X/ X6 m x% p) O
/ t/ t8 ]2 b7 ^: j+ p4 f
;;; =========== for Test only =========================================
2 v% O; f% z6 f
;;; 删除线段内的短线, I9 F& Z' V6 ]! X
;; ssen = Line Selection2 R" f t2 Y: P9 O
(setq nn (sslength ssen))4 r2 ~$ L# D5 e" G8 I! L
(cond y3 P& G- a" i+ W' |! X
((< nn 2) nil) ; Nothing to do7 S- b3 r, X6 H" h/ R' o# d
(T
Y) O2 F' y3 S; X
(princ "\nProceeding with Line ....."! d1 n) `2 s2 }" X; a
(while (setq ee (ssname ssen (setq nn (1- nn)))) 0 I3 U$ A, J. {- c( J! \
(cond) _# T$ D! u' X7 q P; A
((null (entget ee))) ; bypass
8 {" n9 A! D1 N) z4 p
(T
3 @+ B: b9 t) n6 n) _
(setq p1 (dxg 10 ee)
: D" b) b" I7 B& V2 J. V. j
p2 (dxg 11 ee)
8 n5 E( _3 I" a B0 N; s
v1 (angle p1 p2)2 M7 A- m( N; I! b3 t ?; J
e1d (cdddr (cddr (entget ee)))1 W5 S+ ] n; }! E% P
sc (ssget "f" (list p1 p2) '((0 . "LINE")+ D1 g, }4 N/ G/ e
sum (if sc (sslength sc))
3 o' h9 ]0 b! g, m# I
)
% Z9 s$ {, w: @) b- M
(while (and (entget ee) (> sum 0))4 t" T- P% l' v; I1 L2 n
(setq e1 (ssname sc (setq sum (1- sum))))
! U9 s+ h$ Z8 z
(cond N7 C& f3 ]7 a, q
((eq e1 ee) nil) ; Itself8 v6 H8 ~6 V) Y- t8 G4 E
((equal (cdddr (cdddr (entget e1))) e1d)8 `6 F& @2 h0 W: a
(entdel e1)0 X+ U E: Z, J! A! a' w; v
)
: q6 ]& _) Q5 Z5 A. D
(T% O5 r7 q$ [7 K5 _. h2 y: _
(setq p3 (dxg 10 e1)( r8 Z2 O# k' Z: L
p4 (dxg 11 e1)
, }- T+ v6 T& o
v2 (if (vpt p1 p3 5)/ \! @! K1 E8 v; E/ F) l# U7 n( M
(angle p2 p3)
- y4 c m6 S4 ^# a
(angle p1 p3)
u2 [3 D6 _5 ]+ w, n
)' [# b: a! r- V3 C2 _- a2 Y1 t
): o0 B( ?& ^0 t4 v- d
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
. J+ z3 k8 @) h8 D
(if (< (distance p3 p4) (distance p1 p2))
. `& C$ ~ I* k0 @, G
(entdel e1)
) V! _/ ~0 W5 p5 ^! P4 e4 n
(entdel ee)
" B4 ^. F* O! C1 z( q# ~
)% W( h6 [) ?; q: ^) {. N' K6 Q1 m5 E3 f
)
( r- |$ e e5 O: |+ a! k
)
6 S/ W; b& C9 Z' U/ a
)* I# S0 F9 s, }& v' J' S5 t0 C
)
3 v7 G0 \( Y/ |: e, Q; r7 ^, h
)
& K2 T3 @# M$ \
)7 u0 G- V) m! e/ R
)
; B$ l6 C2 q/ A0 g- t4 D
)7 E9 a! x1 N6 d( C3 C* D% t8 A
)
, U k. y1 o' K
* W( w+ x5 z& z1 i

复制代码

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

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

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

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

通知

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

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

评分

评分

评分

浏览过的版块