xjfa 发表于 2011-8-15 10:33:50

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

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

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


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

gbhsu 发表于 2011-8-16 03:09:16

顶一个！！！

198526 发表于 2011-8-16 08:24:08

赞一个！

qcw911 发表于 2011-8-16 08:41:24

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

cxs259 发表于 2011-8-16 09:48:46

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

xjfa 发表于 2011-8-16 12:46:54

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

cxs259 发表于 2011-8-16 22:17:46

看看下面程序也是捕捉的问题，替换的图块也经常不见
;图块替换
(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 发表于 2019-9-15 14:24:57

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


图框，里面的字用的字段，刷不了。烦请改下
页: [1]
查看完整版本: 求高手帮忙编一个可以刷块的LISP