TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: curmudgeon on April 02, 2009, 01:17:09 PM
-
I hope I was concise in the topic - I am in a hurry.
I have a friend with a problem. he has a very large file with many blocks that he needs to use as a background.
we discussed options, but he wants to redefine all the blocks in the drawing such that the entities within have colour bylayer.
OK
I think it will look like a tablesearch of blocks and processing each entity. in order to get each entity "bylayer" .
I believe the correct method is to just not set the colour dxf code at all. default is bylayer.
I am going to try to solve this for it's academic merit, but to get it done in time to do my friend any good, this go around, I would love any help I can get. perhaps there is one sitting on the shelf somewhere around here.
thanks,
roy
(entget (cdr (assoc -2 (tblnext "block"))))
-
http://www.theswamp.org/index.php?topic=6228.msg75946#msg75946
-
thanks, but I get
; error: no function definition: VLAX-GET-ACAD-OBJECT
I assume I need to load some vlax, but I have never done that before.
so far on my end, I setq it to an entity with a forced colour (62 . 4) and
(setq it (subst (cdr (member (assoc 62 it) it)) (member (assoc 62 it) it) it))
(entmod it)
(entupd (cdr (assoc -1 it)))
I will look up vlax in the help files to see if I can get things running.
-
thanks, but I get
; error: no function definition: VLAX-GET-ACAD-OBJECT
execute this before invoking any activex based lisp:
(vl-load-com)
-
You can have a look to Edit_Bloc (http://www.theswamp.org/index.php?topic=11891.msg208061#msg208061) routine wich can do this and some more.
-
...he wants to redefine all the blocks in the drawing such that the entities within have colour bylayer.
One word: SETBYLAYER
-
I have an old one....but don't know the author name.
It work since autoCAD 12 to 2009 (2010 not tested)
; 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 C:FB () (d_FixBlock))
-
This is a complete routine. I wish it is helpful for you.
(vl-load-com)
;;; 运行命令test
;;; Run command: test
(defun c:test (/ LayLst)
(setq *APP (vlax-get-acad-object))
(setq *DOC (vla-get-ActiveDocument *APP))
(setq *BLK (vla-get-blocks *DOC))
(setq LayLst (Get_Layer_Status *DOC))
(Unlock_All_Layers *DOC)
(Thaw_All_Layers *DOC)
(change-entities-in-blocks *BLK)
(Restore_Layer_Status LayLst)
(princ)
)
;;; 主要函数
;;; Main function
(defun change-entities-in-blocks (*BLK / name blks)
(vlax-for blk *BLK
(vlax-for Obj blk
(vla-put-Color Obj 256) ;256 byLayer
(if (or
(= (vla-get-objectname obj) "AcDbBlockReference")
(= (vla-get-objectname obj) "AcDbMInsertBlock")
)
(foreach Att (vlax-invoke Obj 'GetAttributes)
(vla-put-Color Att 256) ;256 byLayer
)
)
)
)
)
;;; 以下函数仅仅为防止出错用
;;; These functions below to avoid some errors
;;; ==========================================
;;; 得到图层状态
;;; Get the status of All layers
(defun Get_Layer_Status (*DOC / laylst)
(setq laylst (vla-get-layers *DOC))
(mapcar
(function
(lambda (x / lst)
(vlax-for n laylst
(setq lst (cons (cons n (vlax-get-property n x)) lst))
)
)
)
(list "LayerOn" "Lock" "Freeze")
)
)
;;; 恢复图层状态
;;; Restore the status of All layers
(defun Restore_Layer_status (LayLst /)
(mapcar
(function
(lambda (x y)
(foreach n X
(if (or (/= (vla-get-name (car n)) (getvar "CLAYER"))
(/= y "Freeze")
) ;对于当前层排除冻结操作,以防出错
(vlax-put-property (car n) y (cdr n))
)
)
)
)
LayLst
(list "LayerOn" "Lock" "Freeze")
)
)
;;; 解锁所有图层
;;; Unlock all layers
(defun Unlock_All_Layers (*DOC)
(vlax-for n (vla-get-layers *DOC)
(vla-put-lock n :vlax-false)
)
)
;;; 解冻所有图层
;;; Thaw all layers
(defun Thaw_All_Layers (*DOC)
(vlax-for n (vla-get-layers *DOC)
(if (/= (vla-get-name n) (getvar "CLAYER"))
(vla-put-Freeze n :vlax-false)
)
)
)
-
MP - I wandered through the help files, saw (vl-load-com) and guessed that it would serve. I pasted it into the vlax I got here and she ran. So, I sent THAT to my friend. thanks. this was the first time I had used that particular command.
gile - thanks for the link to your code. plainly, I have not had enough time to appreciate it fully. I will take that time. when I get out of this chair, this afternoon I am chauffeuring my two youngest to French class(es). as I look through your code, I will see if we can read your comments in their original form.
:-)
Matt - your one word means nothing to me. perhaps the fact that I am running Autocad 2000 like it came out of the box has a lot to do with that. Autocad 2009, I have a copy I have access to at the "branch office", but I have not needed it yet. so I remain ignorant of any particulars. of Revit, I got another friend to take one of his files and export to gbXML so that I could use it to reverse engineer and to write lisp to write to gbXML. specifically, a destination program is HAP. Revit uses undocumented tags, or I do not have the most current schema.
thanks again guys.
and as I hit the POST button, I see I have two more replies. THANK YOU ALL, AND I WILL REVIEW EVERY HELPFUL COMMENT AS SOON AS I RETURN.
EOF
-
You can have a look to Edit_Bloc (http://www.theswamp.org/index.php?topic=11891.msg208061#msg208061) routine wich can do this and some more.
Gile
A great tool, thanks for sharing it.
Gary