[测试]：速度飞快的消重图元测试版

katima · 发表于 2005-2-28 13:07:09

有时间限制的不敢用~~~

tianwen612 · 发表于 2005-3-3 16:50:26

去掉时间限制吧~~

timnis · 发表于 2005-4-14 00:36:27

是呀，能否去掉时间限制呀！测试版吗！等正版再加吗。

userzhluserzhl · 发表于 2005-7-7 18:00:57

请哪位修改一下：

(defun chinslt (bn1 bn2 lt2 / e lt1 ll)
(setq lt2 (cons 6 lt2)
ll (tblsearch "block" bn1)
e (cdr (assoc -2 ll))
ll (subst (cons 2 bn2) (cons 2 bn1) ll)
)
(entmake ll)
(while e
(setq ll (cdr (entget e))
e (entnext e)
lt1 (assoc 6 ll)
ll (if lt1
(subst lt2 lt1 ll)
(append ll (list lt2))
)
)
(entmake ll)
)
(entmake lbe)
)
;;变虚线
(defun c:chdash (/ lbe ss ssl e bn1 bn2 ll lbn tfbd tfbd1)
(princ "\n请选取要变换线型的图元 <退出>: ")
(if (setq ss (ssget))
(progn
(command ".undo" "a" "off" ".undo" "g")
(setq lbe '((0 . "ENDBLK"))
ssl (ssadd)
)
(getss ss 0)
(setq e (namess 0)
bn2 (if (= "INSERT" (socas 0))
(car (xdout e "LT_MARK"))
(socas 6)
)
tfbd (and bn2 (wcmatch bn2 "DASH*"))
)
(while e
(if (= "INSERT" (socas 0))
(progn
(setq bn1 (socas 2)
ll (xdout e "LT_MARK")
tfbd1 (and ll (wcmatch (car ll) "DASH*"))
)
(if (equal tfbd tfbd1)
(progn
(if ll
(progn
(setq bn2 (cadr ll))
(if (or (not (tblsearch "block" bn2)) (= bn1 bn2))
(chinslt bn1 bn2 "BYLAYER")
)
(xdin e "LT_MARK")
)
(progn (if (setq ll (assoc bn1 lbn))
(setq bn2 (cdr ll))
(progn (setq bn2 (rndname)
lbn (cons (cons bn1 bn2) lbn)
)
(chinslt bn1 bn2 "DASH")
)
)
(xdin e "LT_MARK" "DASH" bn1)
)
)
(modent 2 bn2)
)
)
)
(ssadd e ssl)
)
(setq e (namess 0))
)
(if (> (sslength ssl) 0)
(command ".chprop"
ssl
""
"lt"
(if tfbd
"bylayer"
"dash"
)
""
)
)
;(setvar "ltscale" (* 1000 (schdim "normal")))
(command ".undo" "e" ".undo" "a" "on")
)
)
(princ)
)
;;变线形比例
(defun c:chltyp (/ lbe ss ss1 e bl blc na0 na1
n d str fna llt llna chna getlt tfins
)
(defun chna ()
(getss ss 0)
(while (and (setq e (namess 0)) (not (setq na0 (getlt)))))
(if na0
(progn (setq n (strlen na0))
(while (= 'INT (type (read (substr na0 n))))
(setq n (1- n))
)
(if (= "_" (substr na0 n 1))
(setq blc (/ (atof (substr na0 (1+ n))) 100)
na0 (substr na0 1 (1- n))
)
(setq blc 1.)
)
)
)
)
(defun getlt (/ lay ltn)
(if (and (setq tfins (= "INSERT" (socas 0)))
(setq ltn (xdout e "LT_MARK"))
)
(car ltn)
(if (and (not tfins) (setq ltn (socas 6)))
(if (/= "CONTINUOUS" ltn)
ltn
)
(progn (setq lay (socas 8))
(if (setq ltn (assoc lay llna))
(setq ltn (cdr ltn))
(setq ltn (cdr (assoc 6 (tblsearch "layer" lay)))
ltn (if (/= "CONTINUOUS" ltn)
ltn
)
llna (cons (cons lay ltn) llna)
)
)
ltn
)
)
)
)
(princ "\n请选取要改变线型比例的图元 <退出>: ")
(if (and (setq ss (ssget)) (chna))
(progn
(initget 6)
(setq lbe '((0 . "ENDBLK"))
bl (getreal
(strcat "\n要改变线型的放大系数 <" (rtos blc 2 2) ">: ")
)
bl (if bl
bl
blc
)
blc (rtos (* 100 bl) 2 0)
fna (strcat (getcd) "oo_o.lin")
)
(command ".undo" "a" "off" ".undo" "g")
(getss ss 0)
(while (setq e (namess 0))
(if (setq na0 (getlt))
(progn
(setq n (strlen na0))
(while (= 'INT (type (read (substr na0 n))))
(setq n (1- n))
)
(if (= "_" (substr na0 n 1))
(setq na0 (substr na0 1 (1- n)))
)
(setq na1 (if (= 1 bl)
na0
(strcat na0 "_" blc)
)
llt (tblsearch "LTYPE" na1)
)
(if (not llt)
(progn
(setq llt (tblsearch "LTYPE" na0)
n (1- (cdr (assoc 73 llt)))
llt (member (assoc 49 llt) llt)
d (* bl (cdar llt))
str (rtos d 2 4)
)
(repeat n
(setq llt (cdr llt)
d (* bl (cdar llt))
str (strcat str "," (rtos d 2 4))
)
)
(setvar "expert" 3)
(command ".linetype" "c" na1 fna "" str "l" na1 fna "")
(setvar "expert" 0)
(fdel fna)
)
)
(if tfins
(progn
(setq na0 (socas 2))
(chinslt na0 na0 na1)
(setq
ss1 (ssget "X" (list '(0 . "INSERT") (cons 2 na0)))
)
(getss ss1 1)
(while (setq e (namess 1)) (xdin e "LT_MARK" na1 na0))
)
(modent 6 na1)
)
)
)
)
(command ".undo" "e" ".undo" "a" "on")
)
)
(princ)
)

(defun chinslt (bn1 bn2 lt2 / e lt1 ll) 
  (setq        lt2 (cons 6 lt2) 
        ll  (tblsearch "block" bn1) 
        e   (cdr (assoc -2 ll)) 
        ll  (subst (cons 2 bn2) (cons 2 bn1) ll) 
  ) 
  (entmake ll) 
  (while e 
    (setq ll  (cdr (entget e)) 
          e   (entnext e) 
          lt1 (assoc 6 ll) 
          ll  (if lt1 
                (subst lt2 lt1 ll) 
                (append ll (list lt2)) 
              ) 
    ) 
    (entmake ll) 
  ) 
  (entmake lbe) 
) 
 
 
;;变虚线 
(defun c:chdash        (/ lbe ss ssl e bn1 bn2 ll lbn tfbd tfbd1) 
  (princ "\n请选取要变换线型的图元 <退出>: ") 
  (if (setq ss (ssget)) 
    (progn 
      (command ".undo" "a" "off" ".undo" "g") 
      (setq lbe        '((0 . "ENDBLK")) 
            ssl        (ssadd) 
      ) 
      (getss ss 0) 
      (setq e         (namess 0) 
            bn2         (if (= "INSERT" (socas 0)) 
                   (car (xdout e "LT_MARK")) 
                   (socas 6) 
                 ) 
            tfbd (and bn2 (wcmatch bn2 "DASH*")) 
      ) 
      (while e 
        (if (= "INSERT" (socas 0)) 
          (progn 
            (setq bn1        (socas 2) 
                  ll        (xdout e "LT_MARK") 
                  tfbd1        (and ll (wcmatch (car ll) "DASH*")) 
            ) 
            (if        (equal tfbd tfbd1) 
              (progn 
                (if ll 
                  (progn 
                    (setq bn2 (cadr ll)) 
                    (if        (or (not (tblsearch "block" bn2)) (= bn1 bn2)) 
                      (chinslt bn1 bn2 "BYLAYER") 
                    ) 
                    (xdin e "LT_MARK") 
                  ) 
                  (progn (if (setq ll (assoc bn1 lbn)) 
                           (setq bn2 (cdr ll)) 
                           (progn (setq        bn2 (rndname) 
                                        lbn (cons (cons bn1 bn2) lbn) 
                                  ) 
                                  (chinslt bn1 bn2 "DASH") 
                           ) 
                         ) 
                         (xdin e "LT_MARK" "DASH" bn1) 
                  ) 
                ) 
                (modent 2 bn2) 
              ) 
            ) 
          ) 
          (ssadd e ssl) 
        ) 
        (setq e (namess 0)) 
      ) 
      (if (> (sslength ssl) 0) 
        (command ".chprop" 
                 ssl 
                 "" 
                 "lt" 
                 (if tfbd 
                   "bylayer" 
                   "dash" 
                 ) 
                 "" 
        ) 
      ) 
      ;(setvar "ltscale" (* 1000 (schdim "normal"))) 
      (command ".undo" "e" ".undo" "a" "on") 
    ) 
  ) 
  (princ) 
) 
 
 
;;变线形比例 
 
(defun c:chltyp        (/     lbe   ss           ss1         e     bl    blc   na0         na1 
                 n     d     str   fna         llt   llna  chna  getlt tfins 
                ) 
  (defun chna () 
    (getss ss 0) 
    (while (and (setq e (namess 0)) (not (setq na0 (getlt))))) 
    (if        na0 
      (progn (setq n (strlen na0)) 
             (while (= 'INT (type (read (substr na0 n)))) 
               (setq n (1- n)) 
             ) 
             (if (= "_" (substr na0 n 1)) 
               (setq blc (/ (atof (substr na0 (1+ n))) 100) 
                     na0 (substr na0 1 (1- n)) 
               ) 
               (setq blc 1.) 
             ) 
      ) 
    ) 
  ) 
  (defun getlt (/ lay ltn) 
    (if        (and (setq tfins (= "INSERT" (socas 0))) 
             (setq ltn (xdout e "LT_MARK")) 
        ) 
      (car ltn) 
      (if (and (not tfins) (setq ltn (socas 6))) 
        (if (/= "CONTINUOUS" ltn) 
          ltn 
        ) 
        (progn (setq lay (socas 8)) 
               (if (setq ltn (assoc lay llna)) 
                 (setq ltn (cdr ltn)) 
                 (setq ltn  (cdr (assoc 6 (tblsearch "layer" lay))) 
                       ltn  (if        (/= "CONTINUOUS" ltn) 
                              ltn 
                            ) 
                       llna (cons (cons lay ltn) llna) 
                 ) 
               ) 
               ltn 
        ) 
      ) 
    ) 
  ) 
  (princ "\n请选取要改变线型比例的图元 <退出>: ") 
  (if (and (setq ss (ssget)) (chna)) 
    (progn 
      (initget 6) 
      (setq lbe        '((0 . "ENDBLK")) 
            bl        (getreal 
                  (strcat "\n要改变线型的放大系数 <" (rtos blc 2 2) ">: ") 
                ) 
            bl        (if bl 
                  bl 
                  blc 
                ) 
            blc        (rtos (* 100 bl) 2 0) 
            fna        (strcat (getcd) "oo_o.lin") 
      ) 
      (command ".undo" "a" "off" ".undo" "g") 
      (getss ss 0) 
      (while (setq e (namess 0)) 
        (if (setq na0 (getlt)) 
          (progn 
            (setq n (strlen na0)) 
            (while (= 'INT (type (read (substr na0 n)))) 
              (setq n (1- n)) 
            ) 
            (if        (= "_" (substr na0 n 1)) 
              (setq na0 (substr na0 1 (1- n))) 
            ) 
            (setq na1 (if (= 1 bl) 
                        na0 
                        (strcat na0 "_" blc) 
                      ) 
                  llt (tblsearch "LTYPE" na1) 
            ) 
            (if        (not llt) 
              (progn 
                (setq llt (tblsearch "LTYPE" na0) 
                      n          (1- (cdr (assoc 73 llt))) 
                      llt (member (assoc 49 llt) llt) 
                      d          (* bl (cdar llt)) 
                      str (rtos d 2 4) 
                ) 
                (repeat        n 
                  (setq        llt (cdr llt) 
                        d   (* bl (cdar llt)) 
                        str (strcat str "," (rtos d 2 4)) 
                  ) 
                ) 
                (setvar "expert" 3) 
                (command ".linetype" "c" na1 fna "" str "l" na1 fna "") 
                (setvar "expert" 0) 
                (fdel fna) 
              ) 
            ) 
            (if        tfins 
              (progn 
                (setq na0 (socas 2)) 
                (chinslt na0 na0 na1) 
                (setq 
                  ss1 (ssget "X" (list '(0 . "INSERT") (cons 2 na0))) 
                ) 
                (getss ss1 1) 
                (while (setq e (namess 1)) (xdin e "LT_MARK" na1 na0)) 
              ) 
              (modent 6 na1) 
            ) 
          ) 
        ) 
      ) 
      (command ".undo" "e" ".undo" "a" "on") 
    ) 
  ) 
  (princ) 
)

eachy · 发表于 2005-7-7 18:44:43

你要改什么？这些程序是从天正或者理正中拷贝的吧。

liuyj · 发表于 2005-7-8 08:18:15

是天正2的程序，有些函数改掉了，有些还没改，问题是用别的函数替换了天正2的函数是否有运行上的问题。

Gxiaofeng · 发表于 2005-7-30 00:36:19

最初由 eachy 发布
[B]速度飞快的删重复实体----Vlisp程序测试版

命令： Ea:RemoveMent

测试环境：(DELL NoteBook PIV2.4 256M 40G)

1 3W实体 10-13s 左右

2 9.9W 实体 72s 左右

说明：

1 对曲线如果是反向的不认为是... [/B]

可否说下大概思路呢？

周可非 · 发表于 2005-8-10 23:03:50

能否去掉时间限制

ysx810210 · 发表于 2005-8-11 08:44:35

论坛中有这么一个程序,取选对象,获取数据,把DXF组码中唯一的标记改成相同的,再构成表,从表中的第一个数据扫描整个表,与之相同则删除,再从第二个开始.....至最后倒数第二.不知楼主的程序原理是什么?
加上限制,有必要吗?

hjmhjm · 发表于 2005-9-12 09:14:28

修改系统时间,速度飞快的消重图元测试版可不受限制使用,既然时间限制不了使用,还不如斑竹做个好好人,把时间限制消了.

taner · 发表于 2005-12-5 22:01:47

用2006的OVERKILL不可以吗?

david96007 · 发表于 2005-12-5 22:59:27

我还没用呢就到期了！
估计我的电脑快不了！
随便画的线，阵列了一下，删除了一部分（51000个），差点死机！
加载楼主的程序，准备试一下，可惜已经过期了！

WHGF · 发表于 2005-12-8 08:37:58

用重复图元百分比和时间来表示计算速度会更科学！

NET-JOB · 发表于 2006-7-2 12:40:23

正式版呢？？？

有点小烦 · 发表于 2006-7-28 12:39:41

我想问一下，2006里overkill使用的时候，我觉得有点不大妥，比如对于部分重合的线，他们颜色不同，而在使用overkill的时候，重合部分会被剪掉，而我们做图的时候，往往是以颜色决定线宽的，这样就会使打出的图轮廓受影响，请问这个程序有这个问题么？

账号		自动登录	找回密码
密码			立即注册

[测试]：速度飞快的消重图元测试版

Re: [测试]：速度飞快的消重图元测试版