;;; *****************************************************************************************
;;; 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)

Advertisements