[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。

userzhl · 发表于 2007-2-8 12:46:00

我只想要改图块层的功能，不想改其颜色。

(defun C:ch (/ COL SS CNT IDX BLKNAME DONELIST)
(defun GRP (GCC EL) (cdr (assoc GCC EL)))
(defun UPDATE (BNAME COL / ENAME ELIST)
    (setq ENAME (tblobjname "BLOCK" BNAME))
    (if
      (and ENAME
    (zerop (logand 52 (GRP 70 (entget ENAME '("*")))))
      )
       (progn
(while ENAME
    (if (or (= "INSERT" (GRP 0 (entget ENAME)))
     (= "DIMENSION" (GRP 0 (entget ENAME)))
        )
      (UPDATE (GRP 2 (entget ENAME)) COL)
    )
    (setq ELIST (entget ENAME '("*"))
   ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)
   ELIST (if (assoc 62 ELIST)
    (subst (cons 62 COL) (assoc 62 ELIST) ELIST)
    (append ELIST (list (cons 62 COL)))
         )
    )
    (entmod ELIST)
    (setq ENAME (entnext ENAME))
)
't
       )
    )
)
(if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)
    (princ "\nLayer 0 must be thawed before running FIXBLOCK!\n"
    )
    (progn
      (if
(progn
   (setq COL (acad_colordlg 7))
   (princ "\nPress to fix all Blocks New Color\n")
   (setq CNT 0
SS (ssget '((0 . "INSERT,DIMENSION")))
   )
)
(progn
    (setq IDX (sslength SS))
    (while (>= (setq IDX (1- IDX)) 0)
      (if
        (not
   (member (setq BLKNAME (GRP 2 (entget (ssname SS IDX))))
    DONELIST
   )
        )
(progn
    (if (UPDATE BLKNAME COL)
      (setq CNT (1+ CNT))
    )
    (setq DONELIST (cons BLKNAME DONELIST))
)
      )
    )
)
(while (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))
    (if (UPDATE BLKNAME COL)
      (setq CNT (1+ CNT))
    )
)
      )
      (princ (strcat "\n"
       (itoa CNT)
       " block"
       (if (= CNT 1)
         ""
         "s"
       )
       " redefined New Color\n"
      )
      )
    )
)
(command "_.REGEN")
(princ)
)

userzhl · 发表于 2007-2-9 13:01:00

高手都到哪去了呢？

userzhl · 发表于 2007-2-10 13:17:00

版主都到哪去了？

highflybir · 发表于 2007-2-10 17:07:00

本帖最后由作者于 2007-2-10 17:43:51 编辑

(defun C:cc (/ *DOC blocks ss)
(vl-load-com)
(setq *DOC (vla-get-activeDocument (vlax-get-acad-object)))
(setq blocks (vla-get-blocks *Doc)) ;得到文件的块集合
(prompt "\n请选择块: ")
(if (setq ss (ssget '((0 . "INSERT"))));得到块的选择集
(change-block-layer ss) ;全部改层
)
;;(vla-regen *DOC acActiveViewPort)
(princ)
)
;;;改层函数
(defun change-block-layer (ss / i l ename elist bname blist Layer)
(setq i 0 l (sslength ss)) ;计数器清零
(while (< i l)
(setq EName (ssname ss i)) ;得到插入块图元名
(setq EList (entget EName)) ;得到插入块图元表
(setq Layer (cdr (assoc 8 Elist))) ;得到插入块图层
(setq BName (cdr (assoc 2 EList))) ;得到插入块块名
(setq BList (vla-item blocks BName));得到块内实体集合
(vlax-for n Blist
(vla-put-layer n Layer) ;对块内每个实体改变图层
)
(entupd EName) ;更新插入块图元数据
(setq i (1+ i)) ;计数器加一
)
)

不知道是不是你想要的？

ZZXXQQ · 发表于 2007-2-10 17:19:00

;我只想要改图块层的功能，不想改其颜色。
(defun C:ch (/ COL SS CNT IDX BLKNAME DONELIST)
(defun GRP (GCC EL) (cdr (assoc GCC EL)))
(defun UPDATE (BNAME COL / ENAME ELIST)
(setq ENAME (tblobjname "BLOCK" BNAME))
(if (and ENAME (zerop (logand 52 (GRP 70 (entget ENAME '("*")))))) (progn
(while ENAME
(if (or (= "INSERT" (GRP 0 (entget ENAME)))
(= "DIMENSION" (GRP 0 (entget ENAME)))
)
(UPDATE (GRP 2 (entget ENAME)) COL)
)
(setq ELIST (entget ENAME '("*"))
ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)
; ELIST (if (assoc 62 ELIST)
; (subst (cons 62 COL) (assoc 62 ELIST) ELIST)
; (append ELIST (list (cons 62 COL)))
; )
)
(entmod ELIST)
(setq ENAME (entnext ENAME))
)
't
)
)
)
(if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)
(princ "\nLayer 0 must be thawed before running FIXBLOCK!\n")
(progn
(if (progn (setq COL 256); (setq COL (acad_colordlg 7))
(princ "\nPress to fix all Blocks New Color\n")
(setq CNT 0 SS (ssget '((0 . "INSERT,DIMENSION"))))
)
(progn
(setq IDX (sslength SS))
(while (>= (setq IDX (1- IDX)) 0)
(if (not (member (setq BLKNAME (GRP 2 (entget (ssname SS IDX)))) DONELIST)) (progn
(if (UPDATE BLKNAME COL) (setq CNT (1+ CNT)))
(setq DONELIST (cons BLKNAME DONELIST))
))
)
)
(while (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))
(if (UPDATE BLKNAME COL) (setq CNT (1+ CNT)))
)
)
(princ
(strcat "\n" (itoa CNT) " block" (if (= CNT 1) "" "s") " redefined New Color\n")
)
)
)
(command "_.REGEN")
(princ)
)

;我只想要改图块层的功能，不想改其颜色。
(defun C:ch (/ COL SS CNT IDX BLKNAME DONELIST)
 (defun GRP (GCC EL) (cdr (assoc GCC EL)))
 (defun UPDATE (BNAME COL / ENAME ELIST)
  (setq ENAME (tblobjname "BLOCK" BNAME))
  (if (and ENAME (zerop (logand 52 (GRP 70 (entget ENAME '("*")))))) (progn
   (while ENAME
    (if (or (= "INSERT" (GRP 0 (entget ENAME)))
     (= "DIMENSION" (GRP 0 (entget ENAME)))
        )
      (UPDATE (GRP 2 (entget ENAME)) COL)
    )
    (setq ELIST (entget ENAME '("*"))
   ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)
;   ELIST (if (assoc 62 ELIST)
;     (subst (cons 62 COL) (assoc 62 ELIST) ELIST)
;     (append ELIST (list (cons 62 COL)))
;         )
    )
    (entmod ELIST)
    (setq ENAME (entnext ENAME))
   )
   't
   )
  )
 )
 (if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)
  (princ "\nLayer 0 must be thawed before running FIXBLOCK!\n")
 (progn
  (if (progn (setq COL 256); (setq COL (acad_colordlg 7))
   (princ "\nPress  to fix all Blocks New Color\n")
   (setq CNT 0 SS  (ssget '((0 . "INSERT,DIMENSION"))))
      )
  (progn
   (setq IDX (sslength SS))
   (while (>= (setq IDX (1- IDX)) 0)
    (if (not (member (setq BLKNAME (GRP 2 (entget (ssname SS IDX)))) DONELIST)) (progn
     (if (UPDATE BLKNAME COL) (setq CNT (1+ CNT)))
     (setq DONELIST (cons BLKNAME DONELIST))
    ))
   )
  )
  (while (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))
   (if (UPDATE BLKNAME COL) (setq CNT (1+ CNT)))
  )
 )
  (princ
   (strcat "\n" (itoa CNT) " block" (if (= CNT 1) "" "s") " redefined New Color\n")
  )
 )
)
 (command "_.REGEN")
 (princ)
)

jxphklibin · 发表于 2008-11-20 17:03:00

好程序，我也写了两个，改天传上来

chengzhang · 发表于 2010-5-26 16:37:00

感谢各位高手提供

qazwsx0o0 · 发表于 2010-12-29 11:55:04

学习了，谢谢!

湜１只鱼 · 发表于 2013-1-7 18:19:36

学习了应该不错

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

[转帖][求助]急，急，急，哪位高手帮忙改一下，改图块颜色和层的。

回复：（userzhl）[转帖][求助]急，急，急，哪位高手帮...

评分

浏览过的版块