请高手帮修改一个程序

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' F# M7 }' y% v. k0 K
有没有中间使用变量得说明？做什么用得？

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

( Z( s O2 L0 l
(defun dxg (code ele)
* i* x' d, g5 G7 v# P
(cdr (assoc code (entget ele))); Q. g2 Z, I3 T7 U9 H0 b5 q
)
7 M2 A/ a: x6 ^0 m
+ f- v1 Z% i% Z
% e0 m8 N+ r# B! ~' Q4 \8 v
(defun vpt (a b c)
+ D/ n, C! F$ H. U# p
(equal) w# N. [7 ~ ^0 z
(if (caddr a) a (reverse (cons 0.0 (reverse a))))1 y$ e# O. U$ e4 B" E+ Y6 j
(if (caddr b) b (reverse (cons 0.0 (reverse b))))
& G6 I* W8 H( E# k
(expt 0.1 c) l$ U% u+ u5 ?5 a7 L
)4 r& N& ?* L! \0 l! m
)
0 @" K4 ]" q1 @" d1 W% v
3 Z% G$ V% o- V1 G) M3 }) h8 l3 H
;;; =========== for Test only =========================================
* ^" b2 u: N# r3 Q$ c( a
;;; 删除线段内的短线; W) \( u3 t8 {. E
;; ssen = Line Selection1 T! Y, H ^( _- A; _
(setq nn (sslength ssen))
( R" S- J0 a) c9 o' M+ [
(cond& ^7 r$ D1 V6 T
((< nn 2) nil) ; Nothing to do7 f( a4 B. q$ U* _
(T% I0 |$ e- T' D$ Z- @- y* F) z$ D
(princ "\nProceeding with Line ....."
7 E. _4 P+ n0 P' w- d
(while (setq ee (ssname ssen (setq nn (1- nn))))
# L3 T6 E4 x7 J8 _0 c: Y8 C" Q
(cond
) O3 n) z- ^! l# h7 {2 Q6 p. V6 v8 J
((null (entget ee))) ; bypass
3 A6 z2 k! c! r2 O# |" {( A& o
(T4 K6 r$ J- V, C
(setq p1 (dxg 10 ee)+ f& r4 f4 I9 ?" h/ |6 F
p2 (dxg 11 ee)# K4 g. f* L/ M, o1 G. `
v1 (angle p1 p2)
. n/ K7 p( }: A% U5 R
e1d (cdddr (cddr (entget ee)))% T8 j, ]3 C" J3 F8 u
sc (ssget "f" (list p1 p2) '((0 . "LINE")
( D" R8 F4 ?% C( `* S2 }/ ]" Y6 w
sum (if sc (sslength sc)), ]2 ]6 d6 V( }8 s: \, ~3 w7 d% X
)
$ {9 b0 J4 k3 y8 O9 @
(while (and (entget ee) (> sum 0))
: k3 Y- w( w8 d$ `& p3 z+ a
(setq e1 (ssname sc (setq sum (1- sum))))) B. N; H& _7 o# \/ i3 D1 G
(cond2 R) d* F( x& i% d- A8 _
((eq e1 ee) nil) ; Itself( U7 e; x8 J) y q1 t# w1 {
((equal (cdddr (cdddr (entget e1))) e1d)
1 H; ^9 J0 V1 o/ t
(entdel e1)
" t& I2 I8 D3 u4 q
)
0 J: {* \% t* B9 h( L& U
(T* P1 F7 m- X& O9 Z& G5 X3 T
(setq p3 (dxg 10 e1)
( d9 }9 Y5 j4 V4 w5 p
p4 (dxg 11 e1): [& C9 x% j& }1 _! V$ _
v2 (if (vpt p1 p3 5)
2 H5 D- h L/ D' _; v
(angle p2 p3)
$ D. a- J% B8 Q/ O* r2 L3 I
(angle p1 p3)( z" _+ _. |% T" {! f
)
3 [) h: b' L, ?9 ^3 t. p `
)% W6 M4 E# W% ^. C
(if (< (rem (abs (- v1 v2)) pi) 0.0001)
; _' e" W/ P$ ~$ m' \8 a4 h, G
(if (< (distance p3 p4) (distance p1 p2)); X$ K3 p7 x0 @" m0 R
(entdel e1)
. m6 _: K( S' l+ v
(entdel ee)
( Z! g) N+ K# M0 J/ X
). n- s, q2 c+ X: r3 _
)5 Z. E; g6 e4 y0 |! v' J. T- l
)
# B5 q( d7 C- A
)% K- |' h: Y( S2 a
)5 ?3 V+ J: M: w) _+ h8 T( }
)
$ W* ]& R. x/ e
)% H0 @# N$ ~3 T5 Z- Q7 p
)
0 l* @: F! U) _1 w/ m- P
)& W7 z6 U4 R: q" {
)1 Q/ O! m& H! K: {; K* J4 u
6 ~5 C' a* W8 W- y- h' p

复制代码

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

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

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

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

通知

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

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

评分

评分

评分

浏览过的版块