请高手帮修改一个程序

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% {( a# z* Y; D. N/ 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

: e/ s$ n, ~7 q9 @
(defun dxg (code ele)
1 P- T+ Q, Z$ T# S8 ?# Z% ~* j2 b' \
(cdr (assoc code (entget ele)))
: Q+ u% [% q: a2 B
)
4 h2 q5 t; l' R' |: s8 V1 U
- h( I# Q4 ^0 G8 r: E8 x
$ G0 [7 \2 Z7 x* o
(defun vpt (a b c)
# q0 l2 J( u# K- S c
(equal
* H; K- P1 p% v% b8 h
(if (caddr a) a (reverse (cons 0.0 (reverse a))))
" E" Y& C. C& ^; L4 Q1 D1 |
(if (caddr b) b (reverse (cons 0.0 (reverse b)))); L7 q, X# T3 N: ^( c6 X8 @6 R% s4 e
(expt 0.1 c)
- D: R- _5 w" [( O
)
$ ]( u: b& r$ @: x
)+ `2 j* n5 `9 c, Q9 v; T% V
& P' w% M* ]* M0 l
;;; =========== for Test only =========================================5 j0 Y2 _! g- T7 r$ \3 v
;;; 删除线段内的短线
$ _" h. J0 j( A0 Q Q/ \; c- a
;; ssen = Line Selection
% y4 j( j) q M V1 O
(setq nn (sslength ssen))
( D( y" E% j# i9 B
(cond
- C, b. ~# F4 U' w
((< nn 2) nil) ; Nothing to do
; |+ ^' W+ C6 q/ P$ |
(T7 @/ c' l2 B8 r7 K! y
(princ "\nProceeding with Line ....."- y# _5 q* M' Z% h7 m- l
(while (setq ee (ssname ssen (setq nn (1- nn))))
' u5 Y" g, W3 N9 X/ Q: u( j0 A" n
(cond
1 N! N0 R) r1 }, V0 ~1 l! o6 i
((null (entget ee))) ; bypass# M2 h& T+ x3 g$ e3 A
(T
. z+ k+ u" P3 y' f, C) y
(setq p1 (dxg 10 ee)* t" A3 g; C6 m+ V$ i
p2 (dxg 11 ee)" F% i* o0 w! B% X
v1 (angle p1 p2)
5 Q- d% M" K9 G) i Q
e1d (cdddr (cddr (entget ee)))
. g, o' \4 X2 `6 _' x* g; f& W
sc (ssget "f" (list p1 p2) '((0 . "LINE")) Z0 K+ p* E, i8 p% o; \1 [
sum (if sc (sslength sc))5 W" c- h. b6 f3 v5 C# H, K% ^: ]
)) G U% _' G" J. ^4 C0 m6 o9 e
(while (and (entget ee) (> sum 0))
% |& G' }, v6 F
(setq e1 (ssname sc (setq sum (1- sum))))& z" l H+ i7 R$ a3 d# R7 ^
(cond
; }! [ D4 ^) a- t8 | I6 x! G
((eq e1 ee) nil) ; Itself
4 k; V" d- [. l! S
((equal (cdddr (cdddr (entget e1))) e1d)" A \$ s& |* M- ]% D! ]( |
(entdel e1)
6 W8 Z! L: t l" `: k: }
)
" i9 s. V# T# [+ E' s! I
(T! C) G! k, u- m! V
(setq p3 (dxg 10 e1)7 F M6 D5 G" i: z+ x
p4 (dxg 11 e1)
" j Q* o8 n6 d# e
v2 (if (vpt p1 p3 5) [* r( z$ g4 H: B9 A$ H
(angle p2 p3)* ^) l L7 n D. c3 N" S3 D( D
(angle p1 p3)
+ q k! E% G4 ?8 Q. s5 U; ?) n
). v" j N2 i* Q i
)
$ [/ ^3 L9 \ H8 x' ^
(if (< (rem (abs (- v1 v2)) pi) 0.0001)' @1 G$ L6 E2 J4 Z
(if (< (distance p3 p4) (distance p1 p2))5 O0 ^- N' g: f' Q& C1 q
(entdel e1)
7 [- e8 q+ \& j+ X# D/ t4 e
(entdel ee)
8 T1 K$ \2 S$ B& `% g8 j T
)$ s( ?) O! A2 u
)* Y+ \( w1 W$ {( ]
)& x5 V3 {% u! R7 \
)
. W' o- f4 L: z2 z4 E5 _& d
) X# o# ~0 ^( t$ `
)8 u* d |5 q- x
)5 ^ u0 u; a: g6 D+ C
)
" v$ o8 ^6 N( Q! N. n
)
P) [$ P) [; J# M2 }8 ?. j
)9 W4 `; O; p7 o1 @( e+ Y; w+ z) Y
- d6 \, r1 A" |2 e( A1 }( f

复制代码

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

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

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

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

通知

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

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

评分

评分

评分