请高手帮修改一个程序

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+ z+ c$ `. T t T3 @. ~7 L7 Z
有没有中间使用变量得说明？做什么用得？

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

' t h6 i5 {" y6 a9 S) P
(defun dxg (code ele)
7 [; E1 ~' g9 U7 y ~7 V- b8 n
(cdr (assoc code (entget ele)))2 M% c+ y) S5 q$ g+ ~3 I' A+ b7 P
). b9 e" u' \0 A6 v$ u+ Q/ g
3 Q, F/ F, e' ?+ f
' ?3 Y0 R* u% C7 c
(defun vpt (a b c)
' k7 b5 w( G# B" \7 L
(equal* h$ c+ O5 F: R8 e# G# U5 ^
(if (caddr a) a (reverse (cons 0.0 (reverse a))))! D/ A+ w8 J+ @" z: M: U4 Z
(if (caddr b) b (reverse (cons 0.0 (reverse b))))
. Z8 G8 ]7 h6 i/ R% C
(expt 0.1 c)2 ]8 i: {3 V% l( _: ]) `
)
. O5 b% J& X7 l/ S% d% C
)
- M F# r. c F0 D9 ~7 U
;;; =========== for Test only =========================================; \5 V; N+ U8 P) ~, a- x
;;; 删除线段内的短线/ e* f# U/ f3 e! k4 T, Q# \ A
;; ssen = Line Selection( h6 m% k5 \9 ~( ?; G
(setq nn (sslength ssen))5 ^$ R. l* ~( T
(cond
((< nn 2) nil) ; Nothing to do
( J. _8 W# u, n! }( i
(T
b; S0 \5 E; w3 }# ]
(princ "\nProceeding with Line ....."
/ e+ x: K! d1 ~9 I# z! X& P+ p
(while (setq ee (ssname ssen (setq nn (1- nn))))
: P9 Z" N9 f; x9 b
(cond
0 g$ Q+ d; X% B1 O9 d9 M9 ]
((null (entget ee))) ; bypass8 Z6 L4 L: l D1 _; v" L" e/ k
(T
1 [0 G3 z6 T8 d3 ^/ I
(setq p1 (dxg 10 ee) N5 i( W* C. E9 @8 `. x, }! e
p2 (dxg 11 ee)
! P8 y: F4 x/ Q4 ]$ |, q# u2 q
v1 (angle p1 p2)
8 _3 V, d+ q; w8 d
e1d (cdddr (cddr (entget ee)))
' P |; v6 ^8 ^
sc (ssget "f" (list p1 p2) '((0 . "LINE")0 B7 c5 c% ^. `' O" W* ]
sum (if sc (sslength sc))
7 w2 m8 J% o1 h! X( i; W$ l
)
3 X. [7 a; @$ Q1 j% y$ ]
(while (and (entget ee) (> sum 0))
# j) D' t& _. \; @- ]) s! b2 l
(setq e1 (ssname sc (setq sum (1- sum))))5 @- ]- y3 s7 R
(cond
9 S; h4 }- e% e
((eq e1 ee) nil) ; Itself
( a. r |3 P9 {. R2 h7 |7 }
((equal (cdddr (cdddr (entget e1))) e1d)
$ ~. N6 n# J6 S y3 L2 `, B0 _
(entdel e1)! j& h2 W0 Y; U+ e' D9 F% Z
)
- ]; w7 S8 h1 K& f+ Y; h) l) V
(T
, u6 i( X" S4 h. _% c
(setq p3 (dxg 10 e1)
, O" ]) d& W3 B9 d
p4 (dxg 11 e1)% c ~) F. j8 R0 S# k
v2 (if (vpt p1 p3 5)# Q! }9 C: l; z) r# B
(angle p2 p3)" q; i. g# i4 D# M! y5 y
(angle p1 p3), Y6 t" x# D) A; M, o
)9 A8 o# H6 [* N: ~
)
, t0 n! C3 J: Y6 _, Z: }
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
6 D" C6 z* C5 o. U
(if (< (distance p3 p4) (distance p1 p2))
7 v6 Y2 F; J1 j( h" d% }
(entdel e1)
. S5 A1 b/ y* X1 E% g% c1 s
(entdel ee)# j+ z! j4 |4 r4 P% a/ G
)' } P; b; q m s( U( k3 H
)! ?( r Y6 Z( \& X# f
)/ e2 | y2 Q; n4 l0 D
)" |9 t1 w, ~' G3 ^$ k; s1 R6 I+ g
)1 m3 S8 n! w5 T. V/ m$ H
)) A" G1 o1 z9 Z
)
9 D: o4 Y) z. @# n4 U6 J# R- P
)! }2 @' t1 X5 G3 J' [/ j3 _
)" }" v4 W* P- {7 W# ?* p
)* t4 E3 d/ n7 R1 y. ~' ~ M
9 q8 X0 s, N( o I9 P/ y+ @

复制代码

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

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

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

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

通知

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

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

评分

评分

评分

浏览过的版块