AMOVE from ASMI: selectable at
First of all Thanks ASMI for the AMOVE lisp.It works great.Now is it possible to modify it so that I can pick certain attributes to move inside the block and not all the attributes.ie: I have a block with many attributes, I want to pick some attributes to align to left and some attributes to align to the right of the block(s) depending on space avalible on the drawing itself.
Here's the code written by ASMI.Great code ASMI!
;; ==================================================================== ;;;; ;;;;AMOVE.LSP - Moves multiple attributes simultaneously ;;;; ;;;; ==================================================================== ;;;; ;;;;Command(s) to call: AMOVE ;;;; ;;;;Select multuple blocks and move all attributes simultaneously. ;;;; ;;;; ==================================================================== ;;;; ;;;;THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY ;;;;MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR ;;;;PARTS OF IT ABSOLUTELY FREE. ;;;; ;;;;THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY ;;;;DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS ;;;;FOR A PARTICULAR USE. ;;;; ;;;; ==================================================================== ;;;; ;;;;V1.0, 14th Julay 2007, Riga, Latvia ;;;;© Aleksandr Smirnov (ASMI) ;;;;For AutoCAD 2000 - 2008 (isn't tested in a next versions) ;;;; ;;;; http://www.asmitools.com ;;;; ;;;; ==================================================================== ;;(defun c:amove(/ atSet actDoc atLst actSp curTxt aFlg laySt mDel bPt dPt *error*) (vl-load-com) (defun *error*(msg) (if tSet (progn (setvar "CMDECHO" 0) (command "_.erase" tSet "") (setvar "CMDECHO" 1) ); end progn ); end if (if laySt (asmi-LayersStateRestore laySt) ); end if (if actDoc (vla-EndUndoMark actDoc) ); end if (princ) ); end of *error*(defun asmi-LayersUnlock(/ restLst)(setq restLst '()) (vlax-for lay(vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))) (setq restLst (append restLst (list (list lay (vla-get-Lock lay) ); end list ); end list ); end append ); end setq (vla-put-Lock lay :vlax-false) ); end vlax-forrestLst ); end of asmi-LayersUnlock(defun asmi-LayersStateRestore(StateList) (foreach lay StateList (vla-put-Lock(car lay)(cadr lay)) ); end foreach (princ) ); end of asmi-LayersStateRestore(defun asmi-GetAttributes(Block / atArr caArr)(append (if (not (vl-catch-all-error-p (setq atArr(vl-catch-all-apply 'vlax-safearray->list (list(vlax-variant-value (vla-GetAttributes Block))))))) atArr); end if (if (not (vl-catch-all-error-p (setq caArr(vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-GetConstantAttributes Block))))))) caArr); end if ); end append ); end asmi-GetAttributes(defun asmi-GetActiveSpace(/ actDoc) (setq actDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (if(= 1(getvar "TILEMODE")) (vla-get-ModelSpace actDoc) (vla-get-PaperSpace actDoc) ); end if ); end of asmi-GetActiveSpace (princ "\n> ") (if (setq atLst(ssget '((0 . "INSERT")(66 . 1)))) (progn (setq atLst(apply 'append (mapcar 'asmi-GetAttributes (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex atLst))))) ); end apply tSet(ssadd) actSp(asmi-GetActiveSpace) laySt(asmi-LayersUnlock) actDoc(vla-get-ActiveDocument (vlax-get-acad-object)) ); end setq(vla-StartUndoMark actDoc)(foreach att atLst (setq curTxt (vla-AddText actSp "Text" (vlax-3D-point '(0.0 0.0 0.0))1.0)) (ssadd(vlax-vla-object->ename curTxt)tSet) (foreach pr '("TextString" "StyleName" "Height" "ScaleFactor" "Backward" "ObliqueAngle" "UpsideDown" "Rotation" "Color" "Layer" "Linetype" "Lineweight" "Alignment") (vlax-put-Property curTxt pr (vlax-get-Property att pr)) ); end foreach (cond ((= 0(vla-get-Alignment att)) (vla-put-InsertionPoint curTxt (vla-get-InsertionPoint att)) (setq aFlg "InsertionPoint") ); end condition #1 ((member(vla-get-Alignment att) '(3 5)) (vla-put-InsertionPoint curTxt (vla-get-InsertionPoint att)) (vla-put-TextAlignmentPoint curTxt (vla-get-TextAlignmentPoint att)) (vla-put-ScaleFactor curTxt (vla-get-ScaleFactor att)) (setq aFlg "InsertionPoint") ); end condition #2 ((not(member(vla-get-Alignment att)'(0 3 5))) (vla-put-TextAlignmentPoint curTxt (vla-get-TextAlignmentPoint att)) (setq aFlg "TextAlignmentPoint") ); end condition #3 ); end cond ); end foreach (command "_.move" tSet "" pause pause) (setq mDel (mapcar '- (vlax-get (vlax-ename->vla-object (ssname tSet(1-(sslength tSet))))aFlg) (vlax-get(last atLst) aFlg) ); end mapcar ); end setq (foreach att atLst (setq bPt(vlax-get att aFlg) dPt(mapcar '+ bPt mDel) ); end setq (vla-Move att(vlax-3d-Point bPt)(vlax-3d-Point dPt)) ); end foreach (setvar "CMDECHO" 0) (command "_.erase" tSet "") (setvar "CMDECHO" 1) (asmi-LayersStateRestore laySt) (vla-EndUndoMark actDoc) ); end progn ); end if (princ) ); end of c:amove(princ "\n http:\\\\www.AsmiTools.com ")(princ "\n Type AMOVE to move multiple attributes at once. ") This will work on individual Blocks, let me know if you had something else in mind
(defun c:amove2 (/ *error* lklst ent Obj bPt gr) (vl-load-com) (defun *error* (msg) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (if lklst (foreach l lklst (vla-put-lock (car l) (cdr l)))) (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) (princ (strcat "\n>"))) (redraw) (princ)) (vlax-for l (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))) (setq lklst (cons (cons l (vla-get-lock l)) lklst)) (vla-put-lock l :vlax-false)) (while (progn (setq ent (car (nentsel "\nSelect Attribute: "))) (cond ((eq 'ENAME (type ent)) (if (not (eq "ATTRIB" (cdr (assoc 0 (entget ent))))) (princ "\n** Object is not an Attribute **") nil)) (t (princ "\n** Nothing Selected **"))))) (setq Obj (vlax-ename->vla-object ent) bPt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint Obj))))(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (while (and (setq gr (grread t 13 0)) (eq 5 (car gr))) (redraw) (vla-move Obj (vla-get-InsertionPoint Obj) (vlax-3D-point (cadr gr))) (grdraw bPt (cadr gr) 3 1)) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (foreach l lklst (vla-put-lock (car l) (cdr l))) (redraw) (princ)) Thx LeeMac, I'll have to try your code once I get back to work. I'm on holiday for a week. Another option:
This will move multiple attributes by tag:
;; ============ Amove2.lsp ===============;;;;FUNCTION:;;Will move Multiple Attribute Tags;;;;SYNTAX: AMOVE2;;;;AUTHOR:;;Copyright (c) 2009, Lee McDonnell;;(Contact Lee Mac, CADTutor.net);;;;VERSION:;;1.0~28.06.2009;;;; ====================================(defun c:amove2 (/ *error* lklst ent Blk Obj bNme ss bPt ObjLst) (vl-load-com) (defun *error* (msg) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (if lklst (foreach l lklst (vla-put-lock (car l) (cdr l)))) (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")) (princ (strcat "\n>"))) (redraw) (princ)) (vlax-for l (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))) (setq lklst (cons (cons l (vla-get-lock l)) lklst)) (vla-put-lock l :vlax-false)) (while (progn (setq ent (car (nentsel "\nSelect Attribute: "))) (cond ((eq 'ENAME (type ent)) (if (not (eq "ATTRIB" (cdr (assoc 0 (entget ent))))) (princ "\n** Object is not an Attribute **") nil)) (t (princ "\n** Nothing Selected **"))))) (setq Blk (vla-ObjectIdtoObject (vla-get-ActiveDocument (vlax-get-acad-object)) (vla-get-OwnerId (setq Obj (vlax-ename->vla-object ent))))) (setq bNme (if (vlax-property-available-p Blk 'EffectiveName) (vla-get-EffectiveName Blk) (vla-get-Name Blk))) (setq ss (ssget "_X" (list (cons 0 "INSERT") (cons 2 bNme) (cons 66 1)))) (if (setq bPt (getpoint "\nSelect Base Point: ")) (progn (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) (setq ObjLst (vl-remove-if-not (function (lambda (x) (eq (vla-get-TagString x) (vla-get-TagString Obj)))) (apply 'append (mapcar 'asmi-GetAttributes (mapcar 'vlax-ename->vla-object (mapcar 'cadr (ssnamex ss))))))) (lmac-ss-drag-move "\nMove Attributes" ObjLst bPt t) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))))(foreach l lklst (vla-put-lock (car l) (cdr l))) (princ)) ;;Asmi(defun asmi-GetAttributes (Block / atArr caArr)(append (if (not (vl-catch-all-error-p (setq atArr (vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-GetAttributes Block))))))) atArr) (if (not (vl-catch-all-error-p (setq caArr (vl-catch-all-apply 'vlax-safearray->list (list (vlax-variant-value (vla-GetConstantAttributes Block))))))) caArr)));; Ghosting Example, by Lee McDonnell(defun lmac-ss-drag-move (msg ss pt hi/ oBjLst MiP MaP bsvec cPLst gr) (vl-load-com) (if msg (prompt (strcat (if (not (vl-string-search "\n" msg)) "\n""") msg))) (or (and (listp ss) (setq OBjLst ss)) (setq oBjLst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))) (vla-getBoundingBox (car oBjLst) 'MiP 'MaP) (setq bsvec (mapcar '- (vlax-safearray->list MiP) pt));;;(mapcar;;; (function;;; (lambda (x);;; (vla-highlight x :vlax-true)));;; (setq cpLst;;; (mapcar 'vla-copy oBjLst))) (while (eq 5 (car (setq gr (grread 't ))) (redraw) (if (and (eq 5 (car gr)) (listp (cadr gr))) (progn (vla-getBoundingBox (car oBjLst) 'MiP 'MaP) (mapcar (function (lambda (x) (vla-move x (vlax-3D-point (mapcar '- (vlax-safearray->list MiP) bsVec)) (vlax-3D-point (cadr gr))))) oBjLst) (if hi (grdraw pt (cadr gr) 3 1)))));;;(mapcar;;; (function;;; (lambda (x);;; (vl-catch-all-apply;;; 'vla-delete;;; (list x)))) cpLst) (redraw))
I have also updated the code in my first post to add some features. Thank you very much for amove2
Your welcome, I'm glad you like it Lee,
I just tried the code above. Very good job, I had to say that !!
Imagine, I was just curious if you'd done some lisping lately... and yup, you did.
Nice one, I'll keep that one in mind for I might have a use for it sometime.
Regards,
Marco
Again and again, Lee Mac to the rescue!
Great lisp work, as always!
Thanks guys I added the following code at the beginning and end:
;--------------------------------------------------
;save current UCS
(setq mUCS (getvar "UCSNAME"))
(command "_UCS" "")
;--------------------------------------------------
;...(the code).........
;--------------------------------------------------
;restore UCS
(command "UCS" "r" mUCS )
;--------------------------------------------------
Regards, ArqStaad
页:
[1]
2