求高手帮忙编一个可以刷块的LISP

xjfa

工作中经常遇到块会发生镜像，一个一个的改太麻烦，请高手帮忙给编一个可以刷块的LISP  谢谢。

Gu_xl

1. ;;;未考虑属性快
   
2. (defun c:BlkBrush(/ ENT ENL P0 $KD KD SS P1 EL NEWL)
   
3.   (setq ent (car (entsel "\n源图块:"))
   
4.         enl (entget ent)
   
5.         )
   
6.   (redraw ent 3)
   
7.   (setq p0 (vlax-3d-point (cdr (assoc 10 enl))))
   
8.   (initget 7 "Yes No  ")
   
9.   (if (not (or (= "Yes" $kd) (= "No" $kd))) (setq $kd "Yes"))
   
10.   (setq kd (getkword (strcat "\n 是否刷新比例尺 [Yes/No]<" $kd ">:")))
    
11.   (if (= "" kd) (setq kd $kd))
    
12.   (setq $kd kd)
    
13.   (while (setq ss (ssget (list (assoc 0 enl))))
    
14.     (repeat (setq n (sslength ss))
    
15.       ((lambda (x / p1 el NewL ppl obj)
    
16.              (setq el (entget x)
    
17.                    p1 (vlax-3d-point (cdr (assoc 10 el)))
    
18.                    NewL (subst (assoc -1 el) (assoc -1 enl) enl)
    
19.                    Newl (subst (assoc 330 el) (assoc 330 enl) Newl)
    
20.                    Newl (subst (assoc 5 el) (assoc 5 enl) Newl)
    
21.                    Newl (subst (assoc 8 el) (assoc 8 enl) Newl)
    
22.                    )
    
23.              (if (assoc 6 el) (setq Newl (subst (assoc 6 el) (assoc 6 enl) Newl)))
    
24.              (if (assoc 62 el) (setq Newl (subst (assoc 62 el) (assoc 62 enl) Newl)))
    
25.              (if (= kd "No")
    
26.                (setq Newl (subst (assoc 41 el) (assoc 41 enl) Newl)
    
27.                        Newl (subst (assoc 42 el) (assoc 42 enl) Newl)
    
28.                        Newl (subst (assoc 43 el) (assoc 43 enl) Newl)
    
29.                        )
    
30.                )
    
31.              (entmod Newl)
    
32.              (vla-move (setq obj (vlax-ename->vla-object x)) p0 p1)
    
33.              
    
34.              )
    
35.         (ssname ss (setq n (1- n)))
    
36.         )
    
37.       )
    
38.     )
    
39.   (redraw ent 4)
    
40. (princ)
    
41.   )
    

;;;未考虑属性快<br /> (defun c:BlkBrush(/ ENT ENL P0 $KD KD SS P1 EL NEWL)<br />   (setq ent (car (entsel "\n源图块:"))<br />         enl (entget ent)<br />         )<br />   (redraw ent 3)<br />   (setq p0 (vlax-3d-point (cdr (assoc 10 enl))))<br />   (initget 7 "Yes No  ")<br />   (if (not (or (= "Yes" $kd) (= "No" $kd))) (setq $kd "Yes"))<br />   (setq kd (getkword (strcat "\n 是否刷新比例尺 [Yes/No]<" $kd ">:")))<br />   (if (= "" kd) (setq kd $kd))<br />   (setq $kd kd)<br />   (while (setq ss (ssget (list (assoc 0 enl))))<br />     (repeat (setq n (sslength ss))<br />       ((lambda (x / p1 el NewL ppl obj)<br />              (setq el (entget x)<br />                    p1 (vlax-3d-point (cdr (assoc 10 el)))<br />                    NewL (subst (assoc -1 el) (assoc -1 enl) enl)<br />                    Newl (subst (assoc 330 el) (assoc 330 enl) Newl)<br />                    Newl (subst (assoc 5 el) (assoc 5 enl) Newl)<br />                    Newl (subst (assoc 8 el) (assoc 8 enl) Newl)<br />                    )<br />              (if (assoc 6 el) (setq Newl (subst (assoc 6 el) (assoc 6 enl) Newl)))<br />              (if (assoc 62 el) (setq Newl (subst (assoc 62 el) (assoc 62 enl) Newl)))<br />              (if (= kd "No")<br />                (setq Newl (subst (assoc 41 el) (assoc 41 enl) Newl)<br />                        Newl (subst (assoc 42 el) (assoc 42 enl) Newl)<br />                        Newl (subst (assoc 43 el) (assoc 43 enl) Newl)<br />                        )<br />                )<br />              (entmod Newl)<br />              (vla-move (setq obj (vlax-ename->vla-object x)) p0 p1)<br />              <br />              )<br />         (ssname ss (setq n (1- n)))<br />         )<br />       )<br />     )<br />   (redraw ent 4)<br /> (princ)<br />   )<br />

gbhsu

顶一个！！！

198526

赞一个！

qcw911

为什么要刷块呢
直接复制不行吗？
直接块替换不是更快吗？

cxs259

请教G版，能否增加捕捉功能，使目标块保持原有位置不变？

xjfa

首先感谢版主的帮助，还有一个疑问向版主请教，为什么刷的块都找不到了？

cxs259

看看下面程序也是捕捉的问题，替换的图块也经常不见
;图块替换
(vl-load-com)
(defun substblk (newblkname      oldblk    / box
boxmax    boxmin    insp      newblk newblkname
newbox    newmax    newmin    oldblk scx
scy
)
  (vla-GetBoundingBox
    (vlax-ename->vla-object oldblk)
    'boxmin
    'boxmax
  )
  (setq boxmin (vlax-safearray->list boxmin)
boxmax (vlax-safearray->list boxmax)
box    (mapcar '- boxmax boxmin)
  )
  (entmake
    (list
      '(0 . "INSERT")
      '(100 . "AcDbEntity")
      '(100 . "AcDbBlockReference")
      (cons 2 newblkname)
      '(10 0.0 0.0 0.0)
      '(41 . 1.0)
      '(42 . 1.0)
      '(43 . 1.0)
    )
  )
  (setq newblk (entlast))
  (vla-GetBoundingBox
    (vlax-ename->vla-object newblk)
    'newmin
    'newmax
  )
  (setq newmin (vlax-safearray->list newmin)
newmax (vlax-safearray->list newmax)
newbox (mapcar '- newmax newmin)
  )
  (setq scx  (/ (car box) (car newbox))
scy  (/ (cadr box) (cadr newbox))
insp (mapcar '- boxmin (mapcar '* newmin (list scx scy 0)))
  )
  (entmod (list (cons -1 newblk)
(cons 10 insp)
(cons 41 scx)
(cons 42 scy)
  )
  )
  (entdel oldblk)
)
(defun c:htk ()
  (cond ((and
   (setq newblkname (getstring "\n新块名:"))
   (if (tblsearch "block" newblkname)
     t
     (alert "查无此块!")
   )
   (setq ss (ssget '((0 . "insert")))) ;请加入自定过滤
)
(setq i -1)
(repeat
   (sslength ss)
    (setq oldblk (ssname ss (setq i (1+ i))))
    (substblk newblkname oldblk)
)
)
  )
  (princ)
)

qianyi0710

Gu_xl 发表于 2011-8-15 13:16

图框，里面的字用的字段，刷不了。烦请改下