29 Wednesday Apr 2015
Posted in Annonymous Blocks, Blocks
(defun c:RU ( / n )
(vlax-for b (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
(setq n (vla-get-name B))
(if (= "*U" (substr n 1 2))
(vla-put-name b (substr n 2))
)
)
)
(c:ru)
25 Tuesday Nov 2014
Posted in Annonymous Blocks, Lisp Collection 2014
;=======================================================================
; UnAnon.Lsp Jul 05, 1998
; Convert An Existing Block Into An Anonymous Block
; Note; The Existing Block Table Definition Will Have To Be Purged
;================== Start Program ======================================
(princ "\nCopyright (C) 1998, Fabricated Designs, Inc.")
(princ "\nLoading UnAnon v1.0 ")
(setq uan_ nil lsp_file "UnAnon")
;================== For Automated Calling From Another Program =========
(defun uan_auto (ar1) (UnAnon ar1))
;================== Macros =============================================
(defun PDot ()(princ "."))
(PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun uan_smd ()
(SetUndo)
(setq olderr *error*
*error* (lambda (e)
(and (/= e "quit / exit abort")
(princ (strcat "\nError: *** " e " *** ")))
(command "_.UNDO" "_END" "_.U")
(uan_rmd))
uan_var '(
("CMDECHO" . 0) ("MENUECHO" . 0) ("MENUCTL" . 0) ("MACROTRACE" . 0)
("OSMODE" . 0) ("SORTENTS" . 119)("MODEMACRO" . ".")
("BLIPMODE" . 0) ("EXPERT" . 0) ("SNAPMODE" . 1) ("PLINEWID" . 0.0)
("ORTHOMODE" . 1) ("GRIDMODE" . 0) ("ELEVATION" . 0) ("THICKNESS" . 0)
("FILEDIA" . 0) ("FILLMODE" . 0) ("SPLFRAME" . 0) ("UNITMODE" . 0)
("TEXTEVAL" . 0) ("ATTDIA" . 0) ("AFLAGS" . 0) ("ATTREQ" . 1)
("ATTMODE" . 1) ("UCSICON" . 1) ("HIGHLIGHT" . 1) ("REGENMODE" . 1)
("COORDS" . 2) ("DRAGMODE" . 2) ("DIMZIN" . 1) ("PDMODE" . 0)
("CECOLOR" . "BYLAYER") ("CELTYPE" . "BYLAYER")))
(foreach v uan_var
(setq m_v (cons (getvar (car v)) m_v)
m_n (cons (car v) m_n))
(setvar (car v) (cdr v)))
(princ (strcat (getvar "PLATFORM") " Release " (substr (ver) 18 2)
" - Convert To Anonymous Blocks ....\n"))
(princ))
(PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun uan_rmd ()
(setq *error* olderr)
(mapcar 'setvar m_n m_v)
(command "_.UNDO" "_END")
(prin1))
(PDot);++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
(command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
(command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 8) 8)
(command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))
(PDot);++++++++++++ Get Entity Name ++++++++++++++++++++++++++++++++++++
(defun GetOne (/ st os)
(setq os (getvar "SNAPMODE") s nil)
(setvar "SNAPMODE" 0)
(while (not st)
(setq st (ssget)))
(while (> (sslength st) 1)
(setq st nil)
(princ "\nOnly 1 At A Time Please\n")
(while (not st)
(setq st (ssget))))
(setvar "SNAPMODE" os)
(setq s (ssname st 0)))
(PDot);++++++++++++ Convert An Anonymous Block To Named Block ++++++++++
(defun UnAnon (b / tdef en ed bc bn bd in) ;Supply ename
(setq bn "TEMP1" bc 1)
(while (tblsearch "BLOCK" bn)
(setq bc (1+ bc) bn (strcat "TEMP" (itoa bc))))
(and (= (type b) 'ENAME)
(setq bd (entget b)
in (cdr (assoc 2 bd))))
(if (or (not bd)
(not in)
(/= "INSERT" (cdr (assoc 0 bd)))
(/= "*U" (substr in 1 2))
(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in))) 4) 4)
(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in))) 16) 16)
(= (logand (cdr (assoc 70 (tblsearch "BLOCK" in))) 32) 32))
(progn
(princ "*** Not An Anonomymous Block *** ")
(setq bn nil bc nil bd nil in nil b nil)
(exit)))
(setq tdef (tblsearch "BLOCK" in)
en (cdr (assoc -2 tdef))
ed (entget en))
(entmake (list (cons 0 "BLOCK")
(cons 2 bn)
(cons 70 0)
(cons 10 (cdr (assoc 10 tdef)))))
(entmake ed)
(while (setq en (entnext en))
(setq ed (entget en))
(entmake ed))
(entmake (list (cons 0 "ENDBLK")))
(setq bd (subst (cons 2 bn) (assoc 2 bd) bd))
(entmod bd)
(entupd b)
(princ (strcat "\n" bn)))
(PDot);************ Main Program ***************************************
(defun uan_ (/ m_v m_n olderr uan_var s)
(uan_smd)
(GetOne)
(UnAnon s)
(uan_rmd))
(defun c:UnAnonall (/ ss i)
(setq ss (ssget "X" (list (cons 0 "INSERT")(cons 67 (if (= (getvar "TILEMODE") 1) 0 1)))))
(and ss
(setq i (sslength ss))
(while (not (minusp (setq i (1- i))))
(setq en (ssname ss i))
(if (= "*U" (substr (cdr (assoc 2 (entget en))) 1 2))
(UnAnon en))))
(prin1))
(PDot);************ Load Program ***************************************
(defun C:UnAnon () (uan_))
(if uan_ (princ "\nUnAnon Loaded\n"))
(prin1)
;================== End Program ========================================
(c:UnAnonall)
25 Tuesday Nov 2014
Posted in Annonymous Blocks, Lisp Collection 2014
;;; *****************************************************************************************
;;; PL_UnBlockCreat.LSP
;;; *****************************************************************************************
;;; Copyright ©2005 Пётр Лоскутов (Alaspher)
;;; e-mail: alaspher@hotmail.com
;;; *****************************************************************************************
;;; ВЕРСИЯ: 2.0 beta
;;; *****************************************************************************************
;;; ОГРАНИЧЕНИЕ ГАРАНТИЙ
;;; ПРОГРАММА РАСПРОСТРАНЯЕТСЯ НА УСЛОВИЯХ "КАК ЕСТЬ".
;;; АВТОР НЕ БЕРЕТ НА СЕБЯ И НЕ ПОДРАЗУМЕВАЕТ КАКИХ-ЛИБО ГАРАНТИЙНЫХ ОБЯЗАТЕЛЬСТВ.
;;; ВЫ ИСПОЛЬЗУЕТЕ ПРОГРАММУ НА СВОЙ РИСК.
;;; АВТОР НЕ БЕРЕТ НА СЕБЯ ОТВЕТСТВЕННОСТЬ ЗА ПОТЕРЮ ДАННЫХ, УЩЕРБ, ПОТЕРЮ ПРИБЫЛИ ИЛИ ЛЮБЫЕ
;;; ДРУГИЕ ПОТЕРИ, ПРОИЗОШЕДШИЕ ВО ВРЕМЯ ИСПОЛЬЗОВАНИЯ ИЛИ НЕПРАВИЛЬНОГО ИСПОЛЬЗОВАНИЯ
;;; ДАННОГО ПРОГРАММНОГО ОБЕСПЕЧЕНИЯ.
;;; *****************************************************************************************
;;; Разрешается использовать, копировать, изменять, и распространять это программное
;;; обеспечение бесплатно, при условии, что программное обеспечение, полностью или частично
;;; включающее данное ПО, будет распространяться на тех-же условиях, а указанные выше знак
;;; авторского права и примечания об ограничениях гарантий будут приводиться во всех копиях.
;;; *****************************************************************************************
;;;
(defun pl:unblockcreat (/ doc sel att blks del insp insb laylc lays ltmp nblck oname space tmp)
(setq doc (vla-get-activedocument (vlax-get-acad-object))
blks (vla-get-blocks doc)
lays (vla-get-layers doc)
sel (vla-get-activeselectionset doc)
)
(vla-clear sel)
(vla-selectonscreen sel)
(if (not (zerop (vla-get-count sel)))
(progn
(if (not (setq insp (getpoint "\nPick point : ")))
(setq insp '(0.0 0.0 0.0))
)
(setq insb (trans insp 1 0)
insp (vlax-3d-point insb)
space (vla-objectidtoobject doc (vla-get-ownerid (vla-item sel 0)))
)
(vla-startundomark doc)
(vlax-for x sel
(setq oname (strcase (vla-get-objectname x))
ltmp (vla-item lays (vla-get-layer x))
)
(if (= (vla-get-lock ltmp) :vlax-true)
(progn (vla-put-lock ltmp :vlax-false) (setq laylc (cons ltmp laylc)))
)
(cond ((= oname "ACDBVIEWPORT") (setq del (cons x del)))
((= oname "ACDBATTRIBUTEDEFINITION") (setq att (cons x att)))
(t (setq tmp (cons x tmp)))
)
)
(foreach d del
(if (= (vla-get-clipped d) :vlax-true)
(setq tmp
(vl-remove
(vlax-ename->vla-object (cdr (assoc 340 (entget (vlax-vla-object->ename d)))))
tmp
)
)
)
)
(if (or tmp att)
(progn
(if (= (vla-get-lock (setq ltmp (vla-get-activelayer doc))) :vlax-true)
(progn (vla-put-lock ltmp :vlax-false) (setq laylc (cons ltmp laylc)))
)
(setq nblck (vla-add blks insp "*U"))
(if tmp
(vla-copyobjects
doc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject (cons 0 (1- (length tmp))))
tmp
)
)
nblck
)
)
(foreach a att
(vla-addattribute
nblck
(vla-get-height a)
(vla-get-mode a)
(vla-get-promptstring a)
(vlax-3d-point
(mapcar (function -)
(vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint a)))
insb
)
)
(vla-get-tagstring a)
(vla-get-textstring a)
)
)
(vla-insertblock space insp (vla-get-name nblck) 1.0 1.0 1.0 0.0)
)
)
(vla-clear sel)
(foreach i (append tmp att) (vla-delete i))
(foreach i laylc (vla-put-lock i :vlax-true))
(vla-endundomark doc)
)
)
(princ)
)
(defun c:unbl () (pl:unblockcreat))
(progn (princ "\nType - 'unbl' in the command string for beginning.") (vl-load-com))
(c:unbl)
