将所有块设置为ByLaye
我搜索了一下，并没有真正找到我想要的结果。我正在寻找一个Lisp，当调用它时，它会将DWG中的每个块更改为ByLayer颜色和线型。
我最近发现了一个有效的，但你必须选择每个区块。
这是我找到的Lisp程序。。
; File Name: FIXBLOCK.LSP
; Description: Puts all of a blocks sub-entities on layer 0 with color and
; linetype set to BYBLOCK. The block, itself, will remain on
; its' original layer.
;
;*******************************************************************************
(defun d_FixBlock (/ eBlockSel ; Block selection
lInsertData ; Entity data
sBlockName ; Block name
lBlockData ; Entity data
eSubEntity ; Sub-entity name
lSubData ; Sub-entity data
iCount ; Counter
)
;; Redefine error handler
(setq
d_#error *error*
*error*d_FB_Error
) ;_ end setq
;; Set up environment
(setq #SYSVARS (#SaveSysVars (list "cmdecho")))
(setvar "cmdecho" 0)
(command "._undo" "_group")
;; Get block from user and make sure it's an INSERT type
(if (setq eBlockSel (entsel "\nSelect block to change :"))
(progn
(if (setq lInsertData (entget (car eBlockSel)))
(if (= (cdr (assoc 0 lInsertData)) "INSERT")
(setq sBlockName (cdr (assoc 2 lInsertData)))
(progn
(alert "Entity selected is not a block!")
(exit)
) ;_ end progn
) ;_ end if
(progn
(alert "Invalid Block Selection!")
(exit)
) ;_ end progn
) ;_ end if
;; Get block info from the block table
(setq
lBlockData (tblsearch "BLOCK" sBlockName)
eSubEntity (cdr (assoc -2 lBlockData))
) ;_ end setq
;; Make sure block is not an Xref
(if (not (assoc 1 lBlockData))
(progn
(princ "\nProcessing block: ")
(princ sBlockName)
(princ "\nUpdating blocks sub-entities. . .")
;; Parse through all of the blocks sub-entities
(while eSubEntity
(princ " .")
(setq lSubData (entget eSubEntity))
;; Update layer property
(if (assoc 8 lSubData)
(progn
(setq lSubData
(subst
(cons 8 "0")
(assoc 8 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
) ;_ end if
;; Update the linetype property
(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "BYBLOCK")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "BYBLOCK"))))
) ;_ end if
;; Update the color property
(if (assoc 62 lSubData)
(progn
(setq lSubData
(subst
(cons 62 0)
(assoc 62 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 62 0))))
) ;_ end if
(setq eSubEntity (entnext eSubEntity))
; get next sub entity
) ; end while
;; Update attributes
(idc_FB_UpdAttribs)
) ; end progn
(alert "XREF selected. Not updated!")
) ; end if
) ; end progn
(alert "Nothing selected.")
) ; end if
;;; Pop error stack and reset environment
(idc_RestoreSysVars)
(princ "\nDone!")
(setq *error* d_#error)
(princ)
) ; end defun
;*******************************************************************************
; Function to update block attributes
;*******************************************************************************
(defun idc_FB_UpdAttribs ()
;; Update any attribute definitions
(setq iCount 0)
(princ "\nUpdating attributes. . .")
(if (setq ssInserts (ssget "x"
(list (cons 0 "INSERT")
(cons 66 1)
(cons 2 sBlockName)
) ;_ end list
) ;_ end ssget
) ;_ end setq
(repeat (sslength ssInserts)
(setq eBlockName (ssname ssInserts iCount))
(if (setq eSubEntity (entnext eBlockName))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
) ;_ end if
(while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))
;; Update layer property
(if (assoc 8 lSubData)
(progn
(setq lSubData
(subst
(cons 8 "0")
(assoc 8 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
) ;_ end if
;; Update the linetype property
(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "BYBLOCK")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "BYBLOCK"))))
) ;_ end if
;; Update the color property
(if (assoc 62 lSubData)
(progn
(setq lSubData
(subst
(cons 62 0)
(assoc 62 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 62 0))))
) ;_ end if
(if (setq eSubEntity (entnext eSubEntity))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
(setq eSubType nil)
) ;_ end if
) ; end while
(setq iCount (1+ iCount))
) ; end repeat
) ; end if
(command "regen")
) ; end defun
;*******************************************************************************
; Function to save a list of system variables
;*******************************************************************************
(defun #SaveSysVars (lVarList / sSystemVar)
(mapcar
'(lambda (sSystemVar)
(setq lSystemVars
(append lSystemVars
(list (list sSystemVar (getvar sSystemVar)))
) ;_ end append
) ;_ end setq
) ;_ end lambda
lVarList
) ;_ end mapcar
lSystemVars
) ;_ end defun
;*******************************************************************************
; Function to restore a list of system variables
;*******************************************************************************
(defun idc_RestoreSysVars ()
(mapcar
'(lambda (sSystemVar)
(setvar (car sSystemVar) (cadr sSystemVar))
) ;_ end lambda
#SYSVARS
) ;_ end mapcar
) ;_ end defun
;*******************************************************************************
; Error Handler
;*******************************************************************************
(defun d_FB_Error (msg)
(princ "\nError occurred in the Fix Block routine...")
(princ "\nError: ")
(princ msg)
(setq *error* d_#error)
(if *error*
(*error* msg)
) ;_ end if
(command)
(if (/= msg "quit / exit abort")
(progn
(command "._undo" "_end")
(command "._u")
) ;_ end progn
) ;_ end if
(idc_RestoreSysVars)
(princ)
) ;_ end defun
;*******************************************************************************
(defun FB () (d_FixBlock))
(fb)
(princ)
此外，如果每次需要时都不进行加载，我无法使这个lisp正常工作。 为什么不直接使用SETBYLAYER命令？ 因为我忘了那个命令。。英雄联盟
lmfao公司
... 很乐意帮忙！：眨眼：
我也是，每次伦德曼用他珍贵的话语提醒我，我总是忘记。
我的例行程序已经准备好交付，但这个命令持有我的能量LOL。。。。 老实说，我对setbyblock了解不多，但这也应该提供一些灵活性
(defun c:blk2def (/ bl tdef fe fd)
;;;GROUP LIST Group_Number Sysvar_Name New_Value
(setq bl '(( 8 "CLAYER" "0")
( 6 "CELTYPE" "BYLAYER")
(39 "THICKNESS" 0.0)
(48 "CELTSCALE" 1)
(62 "CECOLOR" 256)))
(while (setq tdef (tblnext "BLOCK" (not tdef)))
(setq fe (cdr (assoc -2 tdef)))
(princ (strcat "\n" (cdr (assoc 2 tdef))))
(entmake tdef)
(while fe
(setq fd (entget fe))
(foreach g bl
(cond ((not (getvar (nth 1 g))))
((assoc (nth 0 g) fd)
(setq fd (subst (cons (nth 0 g) (nth 2 g))
(assoc (nth 0 g) fd) fd)))
(T
(setq fd (append fd (list (cons (nth 0 g) (nth 2 g))))))))
(entmake fd)
(setq fe (entnext fe)))
(entmake (list (cons 0 "ENDBLK")(cons 8 "0"))))
(command "_.REGENALL")
(prin1))
您可以根据需要操作列表bl。
[列表]
[*]SN有效层名称
[*]线型必须在调用之前存在，才能正常工作。
[*]颜色0-256
[/列表]
它不处理现有属性。
-大卫 啊。。。现在我想起来了。。我希望块中的线条移动到第0层，以及其他所有内容的“bylayer”。。 尝试一下：
(defun c:test ( / acdoc )
;;-----------------------------------------------------------
;; All block objects to Layer "0", Color/Linetype ByLayer
;; Lee Mac 2011-www.lee-mac.com
;;-----------------------------------------------------------
(vlax-for block
(vla-get-blocks
(setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
)
(if
(and
(eq :vlax-false (vla-get-islayout block))
(eq :vlax-false (vla-get-isxref block))
)
(vlax-for object block
(mapcar
(function
(lambda ( property value )
(vl-catch-all-apply 'vlax-put-property (list object property value))
)
)
'(layer color linetype)
(list "0" acbylayer "BYLAYER")
)
)
)
)
(vla-regen acdoc acallviewports)
(princ)
)
(vl-load-com) (princ) 李，
你会杀了我的。这很好，我将使用lisp。。有没有办法使用另一个lisp（或此lisp中的选项）将块的对象放置到插入块的层？
考虑替换此行：
(list "0" acbylayer "BYLAYER")
... 有了这个：
(list (vla-get-layer object) acbylayer "BYLAYER")
页:
[1]
2