[编程交流] AMOVE from ASMI: selectable at

;; ==================================================================== ;;;;                                                                      ;;;;  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-for  restLst ); 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[info] http:\\\\www.AsmiTools.com [info]")(princ "\n[info] Type AMOVE to move multiple attributes at once. [info]")

(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))

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