;;Insert block from another drawing

;; written by Fatty T.O.H (c) 2004 http://forums.autodesk.com/t5/user/viewprofilepage/user-id/66893
;; all rights removed
;; get ObjectDBX document
;; edited 4/20/06
;; edited 5/28/06 by Jeff M (see commented lines)
;; edited 10/5/06
;; edited 3/19/07
;; edited 3/20/07
(defun odbx-test (/ dbx_doc)
;; edited 5/28/06 by Jeff M
;; modified slightly to work with more versions
(or (vl-load-com))
(if (< (setq dbxver (atoi (getvar "ACADVER"))) 15)
(progn (alert
"ObjectDBX method not applicable\nin this AutoCAD version"
)
(exit)
(princ)
(gc)
)
(progn
(if (= (atoi (getvar "ACADVER")) 15)
(progn

(if (not (vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
)
(startapp "regsvr32.exe"
(strcat "/s \"" (findfile "axdb15.dll") "\"")
)
)

(setq dbx_doc (vla-getinterfaceobject
(vlax-get-acad-object)
"ObjectDBX.AxDbDocument"
)
)
)

(setq dbx_doc (vla-getinterfaceobject
(vlax-get-acad-object)
(strcat "ObjectDBX.AxDbDocument." (itoa (fix dbxver)))
)
)
)
)
)
)

(defun BlockList (dwg / blst bname)
(vlax-for a (vla-get-blocks dwg)
(setq bname (vla-get-name a))
(if
(and (equal :vlax-false (vla-get-isxref a))
(equal :vlax-false (vla-get-islayout a))
(not (wcmatch bname "_*,*$*,*|*" ))
(not (vl-string-search "*" bname))
)
(setq blst (cons bname blst))
)
)
(reverse blst)
)

(defun make-lib-dial ()
(setq fname (vl-filename-mktemp "libris.dcl"))
;(setq fname (strcat (getvar "dwgprefix") "librys.dcl"))
(setq fn (open fname "w"))
(write-line "libres : dialog {" fn)
(write-line (strcat "label = " "\"" "COPY BLOCK" "\"" ";") fn)
(write-line ": boxed_column {" fn)
(write-line (strcat "label = " "\"" "Select Block" "\"" ";") fn)
(write-line ": list_box {" fn)
(write-line (strcat "key = " "\"" "b_list" "\"" ";") fn)
(write-line "width = 30; height = 20;}" fn)
(write-line "}" fn)
(write-line "spacer;" fn)
(write-line "ok_cancel; " fn)
(write-line "}" fn)
(close fn)
)

; ;

(defun set_list (name lst)
(start_list name)
(mapcar 'add_list lst)
(end_list))

; ;
(defun run-lib-dial (blk_lst)

(setq dcl_ex (load_dialog fname))
(new_dialog "libres" dcl_ex)
(set_list "b_list" blk_lst)

(action_tile "b_list" (strcat
"(progn "
"(setq b_name (nth (atoi $value) blk_lst)))"
))

(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")

(setq knock (start_dialog))
(unload_dialog dcl_ex)
(done_dialog)
(vl-file-delete fname)
b_name
)
;; main programm :

(defun C:CBO (/ acapp acsp adoc blk_col blk_lst
b_name cert_blk fn fname ipt knock odbx x)

(vl-load-com)
(or acapp
(setq acapp (vlax-get-acad-object))
)
(or adoc
(setq adoc (vla-get-activedocument acapp))
)
(or acsp
(setq acsp (if (= (getvar "CVPORT") 1)
(vla-get-paperspace
adoc)
(vla-get-modelspace
adoc)
)
)
)

(vla-startundomark adoc)

(setq odbx (odbx-test))
(setq fn (getfiled "Select file to copy block from"
""
"dwg"
16
)
)

(if
(setq fname (findfile fn))
(progn
(vla-open odbx fname)
(setq blk_lst (BlockList odbx))
(make-lib-dial)
(setq b_name (run-lib-dial blk_lst))
(if (= knock 1)
(progn
(setq blk_col (vla-get-blocks odbx))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
(function (lambda () (vla-item blk_col b_name)))
)
)
)
(progn
(setq cert_blk (vla-item blk_col b_name))
(not
(vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ()
(vla-copyobjects
odbx
(vlax-safearray-fill
(vlax-make-safearray vlax-vbobject '(0 . 0))
(list (vla-item
(vla-get-blocks odbx)
b_name
)
)
)
(vla-get-blocks adoc)
)
)
)
)
)
)
)
(princ "\Block Not Found")
)
)
)
)
(princ "\File Not Found")
)
;; check if desired block already in the current database:
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
(function (lambda () (vla-item (vla-get-blocks adoc) b_name)))
)
)
)
;; insert block
(progn
(setq ipt (getpoint "\nSpecify insertion point: "))
(vlax-invoke acsp 'InsertBlock ipt b_name 1 1 1 0)
)
(alert "Problem with block copying"
)
)

(vlax-release-object odbx)
(setq odbx nil)
(mapcar (function (lambda (x)
(vl-catch-all-apply
(function (lambda ()
(vlax-release-object x)
)
)
)
)
)
(list cert_blk blk_col)
)

(vla-endundomark adoc)
(gc)(gc)
(princ)
)
; ;
(princ "\n\t\t***\ttype CBO to execute ...\t***")
(princ)
;;;===========code end
(c:cbo)

Advertisements