TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: ozimad on August 28, 2010, 03:13:07 PM
-
Hi!
I have a drawing with 1000 blocks. It my block library.
I do not want to store them in my template file. but i want some of them in my drawing. I have a lisp to insert them.
Lisp checks if the block is in drawing, and if not inserts it from other drawing.
I search the net and no solution.
What do i need to have insted of "blk=F:\\blk.dwg\\blk" to make it work.
Thanks a lot.
(entmake (mapcar 'cons
'(0 8 2 10 50)
(list "INSERT" "0" "blk=F:\\blk.dwg\\blk" (list 0 0 0) 0)
)
)
-
Check this out:
http://www.theswamp.org/index.php?topic=1821.msg24017#msg24017
-
I get error. Looks like a problem with loading objectdbx
; error: Automation Error. Problem in loading application
-
Hi,
Here is my version of Copying a Block from another Drawing, inspired by Tony's code, but with a bit more error trapping etc.
Let me know how you get on:
;;----------------------=={ Copy Block }==--------------------;;
;; ;;
;; Copies the specified block definition from the specified ;;
;; filename to the ActiveDocument using a deep clone ;;
;; operation (Method inspired by Tony Tanzillo) ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; block - string specifying block name to copy ;;
;; filename - filename of drawing from which to copy block ;;
;;------------------------------------------------------------;;
;; Returns: Block definition in ActiveDocument, else nil ;;
;;------------------------------------------------------------;;
(defun LM:CopyBlock ( block filename / acapp acdoc acblk acdocs dbxDoc item )
(vl-load-com)
;; © Lee Mac 2010
(setq acapp (vlax-get-acad-object)
acdoc (vla-get-ActiveDocument acapp)
acblk (vla-get-Blocks acdoc))
(vlax-map-collection (vla-get-Documents acapp)
(function
(lambda ( doc )
(setq acdocs
(cons
(cons (strcase (vla-get-fullname doc)) doc) acdocs
)
)
)
)
)
(if
(and
(not (LM:Itemp acblk block))
(setq filename (findfile filename))
(not (eq filename (vla-get-fullname acdoc)))
(or
(setq dbxDoc (cdr (assoc (strcase filename) acdocs)))
(progn
(setq dbxDoc (LM:ObjectDBXDocument))
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-open (list dbxDoc filename))
)
)
)
)
(setq item (LM:Itemp (vla-get-Blocks dbxDoc) block))
)
(vla-CopyObjects dbxDoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0)) (list item)
)
)
acblk
)
)
(and dbxDoc (vlax-release-object dbxDoc))
(LM:Itemp acblk block)
)
;;-----------------=={ ObjectDBX Document }==-----------------;;
;; ;;
;; Retrieves a version specific ObjectDBX Document object ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: - None - ;;
;;------------------------------------------------------------;;
;; Returns: VLA ObjectDBX Document object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ObjectDBXDocument ( / acVer )
;; © Lee Mac 2010
(vla-GetInterfaceObject (vlax-get-acad-object)
(if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acVer))
)
)
)
;;-----------------------=={ Itemp }==------------------------;;
;; ;;
;; Retrieves the item with index 'item' if present in the ;;
;; specified collection, else nil ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; coll - the VLA Collection Object ;;
;; item - the index of the item to be retrieved ;;
;;------------------------------------------------------------;;
;; Returns: the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Itemp ( coll item )
;; © Lee Mac 2010
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply
(function vla-item) (list coll item)
)
)
)
)
item
)
)
;; Test Function
(defun c:test ( / *error* doc blk dwg pt norm )
(vl-load-com)
;; © Lee Mac 2010
(defun *error* ( msg )
(and dbxDoc (vlax-release-object dbxDoc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(if (and
(setq blk (getstring t "\nSpecify Name of Block to Copy: "))
(setq dwg (getfiled "Select Drawing to Copy From" "" "dwg" 16))
(LM:CopyBlock blk dwg)
(setq pt (getpoint "\nPick Point for Block: "))
)
(progn
(setq norm (trans '(0. 0. 1.) 1 0 t))
(vla-insertBlock
(if
(or
(eq AcModelSpace
(vla-get-ActiveSpace
(setq doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
)
(eq :vlax-true (vla-get-MSpace doc))
)
(vla-get-ModelSpace doc)
(vla-get-PaperSpace doc)
)
(vlax-3D-point (trans pt 1 0)) blk 1. 1. 1.
(angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 norm t))
)
)
)
(princ)
)
[ test function included ]
Lee
-
Nice one Lee and it works in ACAD2000. 8-)
Note to self:
Get DWG first then populate a dialog with a pick list of blocks
Get user choice to copy.
:-)
I'll have some time this afternoon, I hope.
-
Nice one Lee and it works in ACAD2000. 8-)
Thanks Alan :-)
Note to self:
Get DWG first then populate a dialog with a pick list of blocks
Get user choice to copy.
:-)
Ooo! Nice idea - that would be much more intuitive :-)
-
Sorry Alan, it was such a great idea, I couldn't help myself but have a shot at coding it... I hope you don't mind :-)
;;----------------------=={ Copy Block }==--------------------;;
;; ;;
;; Copies the selected block definition from the selected ;;
;; filename to the ActiveDocument using a deep clone ;;
;; operation (Method inspired by Tony Tanzillo) ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
(defun c:cb ( / *error* acapp acdoc acblk spc dwg dbxDoc lst dcfname file dc ptr fl pt norm block )
(vl-load-com)
;; © Lee Mac 2010
(defun *error* ( msg )
(vl-catch-all-apply
'(lambda nil
(and dbxDoc (vlax-release-object dbxDoc))
(and file (eq 'FILE (type file)) (setq file (close file)))
(and dcfname (setq dcfname (findfile dcfname)) (vl-file-delete dcfname))
(and dc (unload_dialog dc))
)
)
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
(setq acapp (vlax-get-acad-object)
acdoc (vla-get-ActiveDocument acapp)
acblk (vla-get-Blocks acdoc))
(setq spc
(if
(or (eq AcModelSpace (vla-get-ActiveSpace acdoc))
(eq :vlax-true (vla-get-MSpace acdoc))
)
(vla-get-ModelSpace acdoc)
(vla-get-PaperSpace acdoc)
)
)
(cond
(
(not (setq dwg (getfiled "Select Drawing to Copy From" "" "dwg" 16)))
(princ "\n*Cancel*")
)
(
(eq dwg (vla-get-fullname acdoc))
(princ "\n** Cannot Copy from Active Drawing **")
)
(
(not (setq dbxDoc (LM:GetDocumentObject dwg)))
(princ "\n** Unable to Interface with Selected Drawing **")
)
(
(not
(progn
(vlax-for b (vla-get-Blocks dbxDoc)
(if (not (or (eq :vlax-true (vla-get-isXRef b))
(eq :vlax-true (vla-get-isLayout b))))
(setq lst (cons (vla-get-name b) lst))
)
)
(setq lst (acad_strlsort (vl-remove-if '(lambda ( x ) (tblsearch "BLOCK" x)) lst)))
)
)
(princ "\n** No distinct Blocks Found in Selected Drawing **")
)
(
(not
(progn
(setq dcfname (vl-filename-mktemp nil nil ".dcl"))
(if (setq file (open dcfname "w"))
(progn
(write-line "copyblock : dialog { label = \"Select Block to Copy...\"; spacer; : list_box { key = \"blocks\"; } spacer; ok_cancel;}" file)
(not (setq file (close file)))
)
)
)
)
(princ "\n** Unable to Write DCL File **")
)
(
(<= (setq dc (load_dialog dcfname)) 0)
(princ "\n** DCL File not Found **")
)
(
(not (new_dialog "copyblock" dc))
(princ "\n** Unable to Load Dialog **")
)
(t
(start_list "blocks")
(mapcar 'add_list lst)
(end_list)
(setq ptr (set_tile "blocks" "0"))
(action_tile "blocks" "(setq ptr $value)")
(setq fl (start_dialog) dc (unload_dialog dc))
(if (and (= 1 fl) (setq pt (getpoint "\nSpecify Point for Block: ")))
(progn
(vla-CopyObjects dbxDoc
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list (LM:Itemp (vla-get-blocks dbxDoc) (setq block (nth (atoi ptr) lst))))
)
)
acblk
)
(setq norm (trans '(0. 0. 1.) 1 0 t))
(if (LM:Itemp acblk block)
(vla-insertBlock spc (vlax-3D-point (trans pt 1 0)) block 1. 1. 1.
(angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 norm t))
)
)
)
(princ "\n*Cancel*")
)
)
)
(and dcfname (setq dcfname (findfile dcfname)) (vl-file-delete dcfname))
(and dbxDoc (vlax-release-object dbxDoc))
(princ)
)
;;-----------------=={ Get Document Object }==----------------;;
;; ;;
;; Retrieves a the VLA Document Object for the specified ;;
;; filename. Document Object may be present in the Documents ;;
;; collection, or obtained through ObjectDBX ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; filename - filename for which to retrieve document object ;;
;;------------------------------------------------------------;;
;; Returns: VLA Document Object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:GetDocumentObject ( filename / acdocs dbx )
(vl-load-com)
;; © Lee Mac 2010
(vlax-map-collection (vla-get-Documents (vlax-get-acad-object))
(function
(lambda ( doc )
(setq acdocs
(cons
(cons (strcase (vla-get-fullname doc)) doc) acdocs
)
)
)
)
)
(cond
( (not (setq filename (findfile filename))) )
( (cdr (assoc (strcase filename) acdocs)) )
( (not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-open
(list (setq dbx (LM:ObjectDBXDocument)) filename)
)
)
)
dbx
)
)
)
;;-----------------=={ ObjectDBX Document }==-----------------;;
;; ;;
;; Retrieves a version specific ObjectDBX Document object ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: - None - ;;
;;------------------------------------------------------------;;
;; Returns: VLA ObjectDBX Document object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ObjectDBXDocument ( / acVer )
;; © Lee Mac 2010
(vla-GetInterfaceObject (vlax-get-acad-object)
(if (< (setq acVer (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acVer))
)
)
)
;;-----------------------=={ Itemp }==------------------------;;
;; ;;
;; Retrieves the item with index 'item' if present in the ;;
;; specified collection, else nil ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; coll - the VLA Collection Object ;;
;; item - the index of the item to be retrieved ;;
;;------------------------------------------------------------;;
;; Returns: the VLA Object at the specified index, else nil ;;
;;------------------------------------------------------------;;
(defun LM:Itemp ( coll item )
;; © Lee Mac 2010
(if
(not
(vl-catch-all-error-p
(setq item
(vl-catch-all-apply
(function vla-item) (list coll item)
)
)
)
)
item
)
)
-
Lee very nice! Thanks for your and CAB help!
Interesting thing i notices, when you try to put scale factor, all dynamic block loose it opportunities. :-)
P.S. Lee i would advice you to add such check and inform user if the block was not in support file.
(if (= nil (tblsearch "BLOCK" blkname))
(print "\nNo block definition un support file")
-
Lee very nice! Thanks for your and CAB help!
Interesting thing i notices, when you try to put scale factor, all dynamic block loose it opportunities. :-)
P.S. Lee i would advice you to add such check and inform user if the block was not in support file.
(if (= nil (tblsearch "BLOCK" blkname))
(print "\nNo block definition un support file")
Which code are you referring to Ozimad?
My first code has this check in the first IF statement, and my second will only allow to select those block which exist in the source drawing file, and will only attempt to insert the block should the definition be successfully copied to the target drawing file. :-)
-
Interesting thing i notices, when you try to put scale factor, all dynamic block loose it opportunities. :-)
Seeing that the block definition is being deep cloned directly from the source drawing, dynamic blocks should be unaffected. However, bear in mind that I am entmake'ing the INSERT, hence I am unaware whether this affects dynamic blocks.
-
I use second code.
It looks like blocks are scaled, not at all axes at one time. Here is the where dynamic opportunities are lost.
But i found the solution i use command "scale" do to this :-D I do not like to use command "functions" in my lisps because i cannot undo all actions in one click. :-)
Anyway thanks Lee for your help!
-
I use second code.
It looks like blocks are scaled, not at all axes at one time. Here is the where dynamic opportunities are lost.
I'm not sure why this would be the case, as I haven't included any scaling in my code, hence blocks are inserted at 1:1:1 scale.
-
All i did was look over Lee's shoulder. 8-)
-
(= nil (tblsearch "BLOCK" blkname))
Looks ugly, mate
Would be better:
(not (tblsearch "BLOCK" blkname))or for lists
(null mylist)Just a thoughts...
~'J'~
-
<snip>
I do not like to use command "functions" in my lisps because i cannot undo all actions in one click.
<snip>
FYI.... To do this, just surround your code in an undo block.
Ie:
(command "_.undo" "_end")
(command "_.undo" "_group") or (command "_.undo" "_begin")
... code ...
(command "_.undo" "_end")
This will let you undo all at once, or with ActiveX
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
.. code ..
(vla-EndUndoMark ActDoc)
It is good practice to end undo's before you start a new one.
-
Tim, would you know of a way to check whether an Undo is 'open-ended' before calling StartUndoMark to start another?
Or, is it OK to call EndUndoMark first in all cases?
-
Lee,
You might want to use ' InsertBlock ' method instead of entmake. With entmake, you would have to entmake all the attributes, and other sub-entities of the block, but with InsertBlock you don't.
-
Tim, would you know of a way to check whether an Undo is 'open-ended' before calling StartUndoMark to start another?
Or, is it OK to call EndUndoMark first in all cases?
I just end them. I haven't ever ran into issues with just ending them, so I have not looked into a way to count them, but I would think there should be a way.
Edit: Look in the help at the system variable ' UndoCtl '. It looks like what you want.
-
Tim, would you know of a way to check whether an Undo is 'open-ended' before calling StartUndoMark to start another?
Or, is it OK to call EndUndoMark first in all cases?
I just end them. I haven't ever ran into issues with just ending them, so I have not looked into a way to count them, but I would think there should be a way.
Edit: Look in the help at the system variable ' UndoCtl '. It looks like what you want.
Thanks mate - will investigate. :-)
-
You might want to use ' InsertBlock ' method instead of entmake. With entmake, you would have to entmake all the attributes, and other sub-entities of the block, but with InsertBlock you don't.
Very good point - I had overlooked that. Will update the code momentarily. :-)
-
Code updated as per Tim's suggestion. :-)
Many thanks Tim for your time perusing the code. :-)
-
Code updated as per Tim's suggestion. :-)
Many thanks Tim for your time perusing the code. :-)
You're welcome.
-
Perhaps something like this Tim:
(and (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark <doc>)
)
(vla-StartUndoMark <doc>)
...
(vla-EndUndoMark <doc>)
-
That should work, as it seems like you can only have one group going at a time. I tried to open more than one group, but once I ended the group, the bit code 8 was gone.
Edit: No need to do an ' and ' though, as just an ' if ' would work, as the second part will always return nil. Not that it matters though.
-
Edit: No need to do an ' and ' though, as just an ' if ' would work, as the second part will always return nil. Not that it matters though.
I agree - an IF would be better programming
*prays Se7en doesn't stumble across earlier post using AND*
-
everyone thanks a lot! for undo block, this is really the solution i need in all my lisps.
I think it would be nice to have CABs break routine with such block, to undo all the breakings by one key press.
-
You're very welcome Ozimad, I enjoyed this thread :-)