I am trying to place two lisps into one and I am having no luck. I even thought about making a lisp that activates the 1st lisp then the second. Again, my head is not working. Could you guys guide me please?
Thanks!
(defun c:blkpick ( / loop e bl ss sss s i ent atts attt atttl layn )
(vl-load-com)
(vla-put-Name
(vla-item
(vla-get-Blocks
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
"REVS") ;;;<-- old block name
"REV") ;;;< -- new block name
(setq loop t)
(while loop
(while (not (eq (cdr (assoc 0 (entget (setq e (car (entsel "\nPick block to put into it's layer : ")))))) "INSERT"))
(prompt "\nPicked entity doesn't belong to INSERT reference... Try picking again...")
)
(setq bl (cdr (assoc 2 (entget e))))
(if (eq (vla-get-isxref (vla-item (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))) bl)) :vlax-true)
(prompt "\nSpecified name of block belongs to attached xref in active document... Try again with different name...")
(setq loop nil)
)
)
(if bl
(progn
(setq ss (ssget "_X" '((0 . "INSERT"))))
(setq sss (ssadd))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(if (eq (cdr (assoc 2 (entget ent))) bl)
(ssadd ent sss)
)
)
(setq s (ssadd))
(repeat (setq i (sslength sss))
(setq ent (ssname sss (setq i (1- i))))
(if (not (eq (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 (entget ent))))))) 4))
(ssadd ent s)
)
)
(if s
(repeat (setq i (sslength s))
(setq ent (ssname s (setq i (1- i))))
(if (eq 1 (cdr (assoc 66 (entget ent))))
(progn
(setq atts (vlax-invoke (vlax-ename->vla-object ent) 'getattributes))
(foreach att atts
(setq attt (vla-get-textstring att))
(setq atttl (cons attt atttl))
)
(setq atttl (reverse atttl))
(setq layn (if (eq (substr bl 1 1) "*") (strcat "" (substr bl 2) "") (strcat bl "")))
(foreach attt atttl
(setq layn (strcat layn "" attt))
)
(if (not (tblsearch "LAYER" layn))
(command "_.-LAYER" "_M" layn "")
)
(entupd (cdr (assoc -1 (entmod (subst (cons 8 layn) (assoc 8 (entget ent)) (entget ent))))))
(setq layn nil atttl nil)
)
(progn
(setq layn (if (eq (substr bl 1 1) "*") (strcat "" (substr bl 2)) bl))
(if (not (tblsearch "LAYER" layn))
(command "_.-LAYER" "_M" layn "")
)
(entupd (cdr (assoc -1 (entmod (subst (cons 8 layn) (assoc 8 (entget ent)) (entget ent))))))
(setq layn nil)
)
)
)
)
)
)
(princ)
)
and the second.
; 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))
