TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: TJAM51 on November 09, 2007, 11:19:11 AM
-
I am seeking a lisp routine thet would allow me to move with either crossing or single pick any attribute. I would like to pick the attribute and then drag it to it's new location.
Thanks
-
Can't be done with simple code. You would have to roll your own code like 'ssget'. There is an option with 'ssget' to get nested entities, but I haven't be able to get it to select attributes on a regular basis, so I wouldn't trust it.
-
Why is there a poll for this?!? :?
-
what's wrong with grips???
-
grips are cool! but sometimes i use my own routines with (nentsel)
-
Here is a quick example of what I'm talking about. It only works with crossing right now, but how you fix that is to not use 'ssget' first, but use 'getpoint' and 'getcorner' and use 'ssget' with those two points to create a crossing selection. You can test where the second point is relative to the first point, and then you know if you have a crossing or a windowing pick style, but I will leave that to you.
(defun c:Testing (/ ss ObjList PtList ll ur SelObjList tempPtList SelMode TestList)
(if (setq ss (ssget))
(progn
(foreach lst (ssnamex ss)
(cond
(
(or
(equal (car lst) 3)
(equal (car lst) 2)
)
(setq ObjList (cons (vlax-ename->vla-object (cadr lst)) ObjList))
(if (equal (car lst) 2)
(setq SelMode "Window")
(setq SelMode "Crossing")
)
)
((equal (car lst) -1)
(foreach sub-lst (cdr lst)
(setq PtList (cons (cadr sub-lst) PtList))
)
)
)
)
(foreach obj ObjList
(foreach att (vlax-invoke obj 'GetAttributes)
(setq TestList nil)
(vla-GetBoundingBox att 'll 'ur)
(setq tempPtList
(list
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(list (car ur) (cadr ll) (caddr ll))
(list (car ll) (cadr ur) (caddr ll))
)
)
(foreach pt tempPtList
(if
(and
(< (caar PtList) (car pt) (caadr PtList))
(< (cadar PtList) (cadr pt) (cadr (caddr PtList)))
)
(progn
(setq TestList (cons T TestList))
(redraw (vlax-vla-object->ename att) 3)
)
)
)
(if (= SelMode "Window")
(if (equal (length TestList) 4)
(setq SelObjList (cons att SelObjList))
)
(if TestList
(setq SelObjList (cons att SelObjList))
)
)
)
)
)
)
SelObjList
)
-
when grips are hard to distinguish
(defun C:MOVEATT (/ Ent EntProps LastPoint LastEnt *error*)
(defun *error* (msg)
(if LastEnt
(entdel LastEnt)
)
(vl-cmdf "._UNDO" "_END")
(if (or (= msg "Function cancelled") (= msg "quit / exit abort"))
(princ)
(princ (strcat "\nError: " msg))
)
)
(setvar "CMDECHO" 0)
(vl-cmdf "._UNDO" "_BEGIN")
(if
(and
(progn (while (not
(and (setq Ent (nentsel "\nSelect an attribute: "))
(= (cdr (assoc 0 (setq EntProps (entget (car Ent))))) "ATTRIB")
)
)
)
Ent
)
(setq LastPoint (cadr Ent)
LastEnt (entmakex
(cons
(cons 0 "TEXT")
(subst
(cons 73 (cdr (assoc 74 EntProps)))
(assoc 74 EntProps)
(subst
(cons
10
(cdr
(assoc
(if
(= 0 (cdr (assoc 72 EntProps)) (cdr (assoc 74 EntProps)))
10
11
)
EntProps
)
)
)
(assoc 10 EntProps)
(vl-remove-if
(function (lambda (g)
(vl-position (car g) '(-1 0 2 5 70 73 100 280 330))
)
)
EntProps
)
)
)
)
)
)
)
(progn
(setvar "LASTPOINT" LastPoint)
(command "._MOVE" LastEnt "" (cadr Ent) PAUSE)
(if (not (equal LastPoint (getvar "LASTPOINT")))
(progn (entmod
(subst (assoc 11 (entget LastEnt))
(assoc 11 EntProps)
(subst (assoc 10 (entget LastEnt)) (assoc 10 EntProps) EntProps)
)
)
(entupd (car Ent))
)
)
(entdel LastEnt)
)
)
(vl-cmdf "._UNDO" "_END")
(princ)
)
-
Vovka, thats quite usefull, but it would be fantastic if the lisp could be modified so that there is an option to pick more than one attribute at a time.
I have no idea how to do that though..?
thanks
-
I thought ssget had a nentsel type flag?
When using the :N selection method, if the user selects a subentity of a complex entity such as a BlockReference, PolygonMesh, or old style polyline, ssget looks at the subentity that is selected when determining if it has already been selected. However, ssget actually adds the main entity (BlockReference, PolygonMesh, etc.) to the selection set. It is therefore possible to have multiple entries with the same entity name in the selection set (each will have different subentity information for ssnamex to report). Because the :N method does not guarantee that each entry will be unique, code that relies on uniqueness should not use selection sets created using this option.
-
I thought ssget had a nentsel type flag?
When using the :N selection method, if the user selects a subentity of a complex entity such as a BlockReference, PolygonMesh, or old style polyline, ssget looks at the subentity that is selected when determining if it has already been selected. However, ssget actually adds the main entity (BlockReference, PolygonMesh, etc.) to the selection set. It is therefore possible to have multiple entries with the same entity name in the selection set (each will have different subentity information for ssnamex to report). Because the :N method does not guarantee that each entry will be unique, code that relies on uniqueness should not use selection sets created using this option.
Doesn't work as one would hope. At least I wasn't able to make it work the way I wanted. That is why I wrote this routine. (http://www.theswamp.org/index.php?topic=19886.0)
-
Vovka, thats quite usefull, but it would be fantastic if the lisp could be modified so that there is an option to pick more than one attribute at a time.
I have no idea how to do that though..?
thanks
one day it really annoyed me to aim at grips. so, i wrote that function with only one purpose - to move an attribute with just two clicks.
i think it's possible (maybe with the help of Tim Willey's routine) to do what you ask. i'll look at it.
-
Here is mine, with some changes made the the sub posted in the other thread. I think I got all the subs.
(defun c:MoveAttText (/ ActDoc Plss CurSpace ObjList tempPtList PtList tempPline BasePt NewPt *error*)
(defun *error* (msg)
(command)
(if (> (sslength Plss) 0)
(command "_.erase" Plss "")
)
(vla-EndUndoMark ActDoc)
)
(defun GetCurrentSpace (Doc / BlkCol SpaceList CurSpace ActSpace temp1)
; Returns the "block object" for the active space
; Thanks to Jeff Mishler
(if (= (getvar "cvport") 1)
(vla-get-PaperSpace Doc)
(vla-get-ModelSpace Doc)
)
)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq Plss (ssadd))
(setq CurSpace (GetCurrentSpace ActDoc))
(if (setq ObjList (SelAtts "Select attributes and/or text to move: " T))
(foreach obj ObjList
(setq tempPtList (GetBBPoints obj))
(setq PtList nil)
(foreach pt tempPtList
(setq PtList (cons (car pt) PtList))
(setq PtList (cons (cadr pt) PtList))
)
(setq tempPline
(vlax-invoke
CurSpace
'AddLightWeightPolyline
(reverse PtList)
)
)
(vla-put-Closed tempPline :vlax-true)
(ssadd (vlax-vla-object->ename tempPline) Plss)
)
)
(if (> (sslength Plss) 0)
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
(setq BasePt (getpoint))
pause
)
(setq NewPt (getvar 'lastpoint))
(setvar 'cmdecho 0)
(command "_.erase" Plss "")
(foreach obj ObjList
(vlax-invoke obj 'Move BasePt NewPt)
)
)
)
(vla-EndUndoMark ActDoc)
(princ)
)
(defun SelAtts (Message bAllowText / Sel EntData Pt1 Pt3 gr p1 p2 p3 p4 po ss SelMode SelObjList flag)
; updated by gile @theSwamp.org to show the selection correctly.
; updated by T.Willey to allow the option to select text objects, not mtext
; updated by T.Willey, added new sub to see if the selection box and the bounding box of the objects
; selected cross, so that a true crossing is simulated
(defun DoBoxesCross (PtList1 PtList2 / Intersect cnt cnt2)
(setq cnt 0)
(while
(and
(not Intersect)
(< cnt 4)
)
(setq cnt2 0)
(repeat 4
(if
(inters
(nth cnt PtList1)
(nth
(if (equal cnt 3)
0
(1+ cnt)
)
PtList1
)
(nth cnt2 PtList2)
(nth
(if (equal cnt2 3)
0
(1+ cnt2)
)
PtList2
)
T
)
(setq Intersect T)
)
(setq cnt2 (1+ cnt2))
)
(setq cnt (1+ cnt))
)
Intersect
)
;----------------------------------------------------------------------------------------------------
(defun GetAttSelection (ss SelMode / ObjList PtList TestList ll ur tempPtList SelObjList)
(foreach lst (ssnamex ss)
(cond
((equal (car lst) 3)
(setq ObjList (cons (vlax-ename->vla-object (cadr lst)) ObjList))
)
((equal (car lst) -1)
(foreach sub-lst (cdr lst)
(setq PtList (cons (cadr sub-lst) PtList))
)
)
)
)
(foreach obj ObjList
(cond
((= (vla-get-ObjectName obj) "AcDbBlockReference")
(foreach att (vlax-invoke obj 'GetAttributes)
(if
(and
(/= (vla-get-TextString att) "")
(= (vla-get-Invisible att) :vlax-false)
)
(progn
(setq TestList nil)
(vla-GetBoundingBox att 'll 'ur)
(setq tempPtList
(list
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(list (car ur) (cadr ll) (caddr ll))
(list (car ll) (cadr ur) (caddr ll))
)
)
(foreach pt tempPtList
(if
(and
(< (caar PtList) (car pt) (caadr PtList))
(< (cadar PtList) (cadr pt) (cadr (caddr PtList)))
)
(setq TestList (cons T TestList))
)
)
(if (= SelMode "Windowing")
(if (equal (length TestList) 4)
(setq SelObjList (cons att SelObjList))
)
(if
(or
TestList
(DoBoxesCross PtList tempPtList)
)
(setq SelObjList (cons att SelObjList))
)
)
)
)
)
)
(
(or
(= (vla-get-ObjectName obj) "AcDbText")
(= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
)
(if
(or
(/= (vla-get-TextString obj) "")
(and
(vlax-property-available-p obj 'TagString)
(/= (vla-get-TagString obj) "")
)
)
(progn
(setq TestList nil)
(vla-GetBoundingBox obj 'll 'ur)
(setq tempPtList
(list
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(list (car ur) (cadr ll) (caddr ll))
(list (car ll) (cadr ur) (caddr ll))
)
)
(foreach pt tempPtList
(if
(and
(< (caar PtList) (car pt) (caadr PtList))
(< (cadar PtList) (cadr pt) (cadr (caddr PtList)))
)
(setq TestList (cons T TestList))
)
)
(if (= SelMode "Windowing")
(if (equal (length TestList) 4)
(setq SelObjList (cons obj SelObjList))
)
(if
(or
TestList
(DoBoxesCross PtList tempPtList)
)
(setq SelObjList (cons obj SelObjList))
)
)
)
)
)
)
)
SelObjList
)
;----------------------------------------------------------------------------------------------------
(defun gr-sel (/ loop gr pt)
(setq loop T)
(while (and (setq gr (grread T 12 2)) (/= (car gr) 3) loop)
(cond
((= (car gr) 5)
(setq pt (cadr gr))
)
(
(or
(member gr '((2 13) (2 32)))
(or (= (car gr) 11) (= (car gr) 25))
)
(setq loop nil
pt nil
)
)
)
)
(if pt
(cond
((car (nentselp pt)))
(pt)
)
)
)
;---------------------------------------------------------------------------------------------------------
(setvar "ErrNo" 0)
(while
(and
(princ (strcat "\n" Message))
(setq sel (gr-sel))
)
(if (listp sel)
(progn
(setq p1 (list (car sel) (cadr sel))
pt1 (trans p1 1 2)
)
(princ "\nSpecify the opposite corner: ")
(while (and (setq gr (grread T 12 1)) (/= (car gr) 3))
(if (= 5 (car gr))
(progn
(redraw)
(setq pt3 (trans (cadr gr) 1 2)
p2 (trans (list (car pt3) (cadr pt1)) 2 1)
p3 (list (caadr gr) (cadadr gr))
p4 (trans (list (car pt1) (cadr pt3)) 2 1)
)
(if (< (car pt1) (car (trans p2 1 2)))
(progn
(setq SelMode "Windowing")
(grvecs (list 255 p1 p2 255 p2 p3 255 p3 p4 255 p4 p1))
)
(progn
(setq SelMode "Crossing")
(grvecs
(list -255 p1 p2 -255 p2 p3 -255 p3 p4 -255 p4 p1)
)
)
)
)
)
)
(redraw)
(if
(if bAllowText
(setq ss (ssget "_C" p1 p3 '((0 . "INSERT,TEXT,ATTDEF"))))
(setq ss (ssget "_C" p1 p3 '((0 . "INSERT"))))
)
(setq SelObjList (append SelObjList (GetAttSelection ss SelMode)))
)
)
(progn
(setq EntData (entget Sel))
(if
(or
(= (cdr (assoc 0 EntData)) "ATTRIB")
(and
bAllowText
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "ATTDEF"))
)
)
(progn
(setq SelObjList
(cons (vlax-ename->vla-object Sel) SelObjList)
)
(redraw Sel 3)
)
)
)
)
(foreach att SelObjList
(redraw (vlax-vla-object->ename att) 3)
)
)
(foreach att SelObjList
(redraw (vlax-vla-object->ename att) 4)
)
SelObjList
)
-
Thanks T.Willey
Moccasin is my favourite color from this time
:))
~'J'~
-
Thank you Vovka if you could that would be fantastic.
T.Willey, I just tried your lisps and have run into a slight problem.
I copied both routines as posted
MoveAttText.lsp and SelAtts.lsp
and apploaded them both and then run movetttext (i'm using autocad 2005).
Command: MoveAttText
Select attributes and/or text to move:
Select attributes and/or text to move: *Cancel*
I cannot seem to get pass the selection part of the routine, space bar seems to cancels.
I can select the attributes, but i cant move onto the next phase.
Thanks again
Least
-
Try 'Right Clicking'. I don't use space bar when selecting stuff, so the code might not accept it. I will test when I get a chance.
-
Right clicking has the same effect.
thanks for looking into it.
-
Looks like the space bar will work also. I don't think I gave the sub, sorry.
(defun GetBBPoints (VlaxObj / tmpLL tmpUR LowLeft LowRight UpRight LowRight)
; Get bounding box points for a valid vlax-object
; Returns a list of point lists.
(vla-GetBoundingBox VlaxObj 'tmpLL 'tmpUR)
(setq LowLeft (safearray-value tmpLL))
(setq UpRight (safearray-value tmpUR))
(setq LowRight (list (car UpRight) (cadr LowLeft) (caddr UpRight)))
(setq UpLeft (list (car LowLeft) (cadr UpRight) (caddr LowLeft)))
(list LowLeft LowRight UpRight UpLeft)
)
-
ah yes!
thats done it
thank you very much, its perfect!
-
T.Willey
I have a request please
with VovKa's single attribute routine the first picked point is used as the base point for the move
is it possible to modify this routine so that the last picked attribute is used as the base point for the move?
thanks
-
ah yes!
thats done it
thank you very much, its perfect!
You're welcome.
T.Willey
I have a request please
with VovKa's single attribute routine the first picked point is used as the base point for the move
is it possible to modify this routine so that the last picked attribute is used as the base point for the move?
thanks
Kind of, but not really. Mine works with a routine to simulate 'ssget' with attributes, so it doesn't know which one is the last one picked, but it does return a list of all the objects selected, so you could use the last item in the list, and grab it's insertion point (or text alignment point if not left justified) and use that for the base point.
-
insertion point, anything will do really its just to save an extra mouse click
I guess that this area would need modifying:
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
(setq BasePt (getpoint))
pause
)
I think i need to edit its so that BasePt is set to the insertion point of the last attribute or any attribute.
How can I set BasePt the coord value of LowLeft (?)?
Cheers
-
insertion point, anything will do really its just to save an extra mouse click
I guess that this area would need modifying:
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
(setq BasePt (getpoint))
pause
)
I think i need to edit its so that BasePt is set to the insertion point of the last attribute or any attribute.
How can I set BasePt the coord value of LowLeft (?)?
Cheers
In this area
(foreach obj ObjList
(setq tempPtList (GetBBPoints obj))
(setq PtList nil)
(foreach pt tempPtList
(setq PtList (cons (car pt) PtList))
(setq PtList (cons (cadr pt) PtList))
)
(setq tempPline
(vlax-invoke
CurSpace
'AddLightWeightPolyline
(reverse PtList)
)
)
(vla-put-Closed tempPline :vlax-true)
(ssadd (vlax-vla-object->ename tempPline) Plss)
)
Add this line
(setq BasePt (car PtList))like
(foreach obj ObjList
(setq tempPtList (GetBBPoints obj))
[color=red](setq BasePt (car PtList))[/color]
(setq PtList nil)
(foreach pt tempPtList
(setq PtList (cons (car pt) PtList))
(setq PtList (cons (cadr pt) PtList))
)
(setq tempPline
(vlax-invoke
CurSpace
'AddLightWeightPolyline
(reverse PtList)
)
)
(vla-put-Closed tempPline :vlax-true)
(ssadd (vlax-vla-object->ename tempPline) Plss)
)
Then change this part
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
(setq BasePt (getpoint))
pause
)
to
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
[color=red]BasePt[/color]
pause
)
-
first of all, thank you T.Willey, you have rescued me trouble :)
Least, you can use this expression to set center point of a selection as a base point
(setq
BasePt (apply
(function
(lambda (p1 p2)
(mapcar (function (lambda (e1 e2) (/ (+ e1 e2) 2.))) p1 p2)
)
)
((lambda (Coords)
(apply
(function
(lambda (mn mx) (mapcar (function (lambda (n x) (list n x))) mn mx))
)
(mapcar (function (lambda (c) (list (apply 'min c) (apply 'max c))))
(list (mapcar 'car Coords) (mapcar 'cadr Coords))
)
)
)
(apply
'append
(mapcar
(function (lambda (Obj)
(vla-GetBoundingBox Obj 'LL 'UR)
(list (vlax-safearray->list LL) (vlax-safearray->list UR))
)
)
ObjList
)
)
)
)
)
don't forget to add LL and UR to locals
-
first of all, thank you T.Willey, you have rescued me trouble :)
You're welcome. It's nice when you can help others that help so much.
-
Ok
i've added the two lines as instructed and run the command:
Command: MOVEATTTEXT
Select attributes and/or text to move:
Select attributes and/or text to move:
Select attributes and/or text to move:
Select attributes and/or text to move: _.move
Select objects: 3 found
Select objects: Specify base point or displacement: 490.2615999989041 Specify
second point of displacement or <use first point as displacement>:
Command:
not quite workng as yet, the base point comes from somewhere way of screen.
so then i commented out this line
; (setq BasePt (car PtList))
and inserted the extra code from Vovka (thank you Vovka)
inserted just before this bit:
(if (> (sslength Plss) 0)
(progn
(setvar 'cmdecho 1)
(command "_.move"
now it will find the centre point perfetly but i cannot move the attributes.
Command: MOVEATTTEXT
Select attributes and/or text to move:
Specify the opposite corner:
Select attributes and/or text to move: _.move
Select objects: 2 found
Select objects: Specify base point or displacement: Specify second point of
displacement or <use first point as displacement>:
Command:
cheers.
-
Sorry. I mis-typed what you wanted to set 'BasePt' to. It should have been
(setq BasePt (car tempPtList))
I just tried it in my routine, and it worked.
-
Yes! Fantastic, it works like a dream. Thank you for your time and expertise.
It would be nice to fix Vovka's centre point function.
I have no idea how to find the error.
Thanks to both you with this.
Least
-
of course 'Move expects a 3d point, sorry
when using my center point change the following
(foreach obj ObjList
(vlax-invoke obj 'Move (append BasePt (cddr NewPt)) NewPt)
)
-
Brilliant, its just the job
thanks for all your help
here it is in full:
; Lisp to move attributes
;
; Thanks to T.Willey & VovKa - Dec 2007
; http://www.theswamp.org/index.php?topic=19881.15
(defun SelAtts (Message bAllowText / Sel EntData Pt1 Pt3 gr p1 p2 p3 p4 po ss SelMode SelObjList flag)
; updated by gile @theSwamp.org to show the selection correctly.
; updated by T.Willey to allow the option to select text objects, not mtext
; updated by T.Willey, added new sub to see if the selection box and the bounding box of the objects
; selected cross, so that a true crossing is simulated
(defun DoBoxesCross (PtList1 PtList2 / Intersect cnt cnt2)
(setq cnt 0)
(while
(and
(not Intersect)
(< cnt 4)
)
(setq cnt2 0)
(repeat 4
(if
(inters
(nth cnt PtList1)
(nth
(if (equal cnt 3)
0
(1+ cnt)
)
PtList1
)
(nth cnt2 PtList2)
(nth
(if (equal cnt2 3)
0
(1+ cnt2)
)
PtList2
)
T
)
(setq Intersect T)
)
(setq cnt2 (1+ cnt2))
)
(setq cnt (1+ cnt))
)
Intersect
)
;----------------------------------------------------------------------------------------------------
(defun GetAttSelection (ss SelMode / ObjList PtList TestList ll ur tempPtList SelObjList)
(foreach lst (ssnamex ss)
(cond
((equal (car lst) 3)
(setq ObjList (cons (vlax-ename->vla-object (cadr lst)) ObjList))
)
((equal (car lst) -1)
(foreach sub-lst (cdr lst)
(setq PtList (cons (cadr sub-lst) PtList))
)
)
)
)
(foreach obj ObjList
(cond
((= (vla-get-ObjectName obj) "AcDbBlockReference")
(foreach att (vlax-invoke obj 'GetAttributes)
(if
(and
(/= (vla-get-TextString att) "")
(= (vla-get-Invisible att) :vlax-false)
)
(progn
(setq TestList nil)
(vla-GetBoundingBox att 'll 'ur)
(setq tempPtList
(list
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(list (car ur) (cadr ll) (caddr ll))
(list (car ll) (cadr ur) (caddr ll))
)
)
(foreach pt tempPtList
(if
(and
(< (caar PtList) (car pt) (caadr PtList))
(< (cadar PtList) (cadr pt) (cadr (caddr PtList)))
)
(setq TestList (cons T TestList))
)
)
(if (= SelMode "Windowing")
(if (equal (length TestList) 4)
(setq SelObjList (cons att SelObjList))
)
(if
(or
TestList
(DoBoxesCross PtList tempPtList)
)
(setq SelObjList (cons att SelObjList))
)
)
)
)
)
)
(
(or
(= (vla-get-ObjectName obj) "AcDbText")
(= (vla-get-ObjectName obj) "AcDbAttributeDefinition")
)
(if
(or
(/= (vla-get-TextString obj) "")
(and
(vlax-property-available-p obj 'TagString)
(/= (vla-get-TagString obj) "")
)
)
(progn
(setq TestList nil)
(vla-GetBoundingBox obj 'll 'ur)
(setq tempPtList
(list
(setq ll (safearray-value ll))
(setq ur (safearray-value ur))
(list (car ur) (cadr ll) (caddr ll))
(list (car ll) (cadr ur) (caddr ll))
)
)
(foreach pt tempPtList
(if
(and
(< (caar PtList) (car pt) (caadr PtList))
(< (cadar PtList) (cadr pt) (cadr (caddr PtList)))
)
(setq TestList (cons T TestList))
)
)
(if (= SelMode "Windowing")
(if (equal (length TestList) 4)
(setq SelObjList (cons obj SelObjList))
)
(if
(or
TestList
(DoBoxesCross PtList tempPtList)
)
(setq SelObjList (cons obj SelObjList))
)
)
)
)
)
)
)
SelObjList
)
;----------------------------------------------------------------------------------------------------
(defun gr-sel (/ loop gr pt)
(setq loop T)
(while (and (setq gr (grread T 12 2)) (/= (car gr) 3) loop)
(cond
((= (car gr) 5)
(setq pt (cadr gr))
)
(
(or
(member gr '((2 13) (2 32)))
(or (= (car gr) 11) (= (car gr) 25))
)
(setq loop nil
pt nil
)
)
)
)
(if pt
(cond
((car (nentselp pt)))
(pt)
)
)
)
;---------------------------------------------------------------------------------------------------------
(setvar "ErrNo" 0)
(while
(and
(princ (strcat "\n" Message))
(setq sel (gr-sel))
)
(if (listp sel)
(progn
(setq p1 (list (car sel) (cadr sel))
pt1 (trans p1 1 2)
)
(princ "\nSpecify the opposite corner: ")
(while (and (setq gr (grread T 12 1)) (/= (car gr) 3))
(if (= 5 (car gr))
(progn
(redraw)
(setq pt3 (trans (cadr gr) 1 2)
p2 (trans (list (car pt3) (cadr pt1)) 2 1)
p3 (list (caadr gr) (cadadr gr))
p4 (trans (list (car pt1) (cadr pt3)) 2 1)
)
(if (< (car pt1) (car (trans p2 1 2)))
(progn
(setq SelMode "Windowing")
(grvecs (list 255 p1 p2 255 p2 p3 255 p3 p4 255 p4 p1))
)
(progn
(setq SelMode "Crossing")
(grvecs
(list -255 p1 p2 -255 p2 p3 -255 p3 p4 -255 p4 p1)
)
)
)
)
)
)
(redraw)
(if
(if bAllowText
(setq ss (ssget "_C" p1 p3 '((0 . "INSERT,TEXT,ATTDEF"))))
(setq ss (ssget "_C" p1 p3 '((0 . "INSERT"))))
)
(setq SelObjList (append SelObjList (GetAttSelection ss SelMode)))
)
)
(progn
(setq EntData (entget Sel))
(if
(or
(= (cdr (assoc 0 EntData)) "ATTRIB")
(and
bAllowText
(vl-position (cdr (assoc 0 EntData)) '("TEXT" "ATTDEF"))
)
)
(progn
(setq SelObjList
(cons (vlax-ename->vla-object Sel) SelObjList)
)
(redraw Sel 3)
)
)
)
)
(foreach att SelObjList
(redraw (vlax-vla-object->ename att) 3)
)
)
(foreach att SelObjList
(redraw (vlax-vla-object->ename att) 4)
)
SelObjList
)
;----------------------------------------------------------------------------------------------------
(defun GetBBPoints (VlaxObj / tmpLL tmpUR LowLeft LowRight UpRight LowRight)
; Get bounding box points for a valid vlax-object
; Returns a list of point lists.
(vla-GetBoundingBox VlaxObj 'tmpLL 'tmpUR)
(setq LowLeft (safearray-value tmpLL))
(setq UpRight (safearray-value tmpUR))
(setq LowRight (list (car UpRight) (cadr LowLeft) (caddr UpRight)))
(setq UpLeft (list (car LowLeft) (cadr UpRight) (caddr LowLeft)))
(list LowLeft LowRight UpRight UpLeft)
)
;---------------------------------------------------------------------------------------------------------
(defun c:MoveAttText (/ ActDoc Plss CurSpace ObjList tempPtList PtList tempPline BasePt NewPt *error* LL UR)
(defun *error* (msg)
(command)
(if (> (sslength Plss) 0)
(command "_.erase" Plss "")
)
(vla-EndUndoMark ActDoc)
)
(defun GetCurrentSpace (Doc / BlkCol SpaceList CurSpace ActSpace temp1)
; Returns the "block object" for the active space
; Thanks to Jeff Mishler
(if (= (getvar "cvport") 1)
(vla-get-PaperSpace Doc)
(vla-get-ModelSpace Doc)
)
)
(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(setq Plss (ssadd))
(setq CurSpace (GetCurrentSpace ActDoc))
(if (setq ObjList (SelAtts "Select attributes and/or text to move: " T))
(foreach obj ObjList
(setq tempPtList (GetBBPoints obj))
(setq BasePt (car tempPtList))
(setq PtList nil)
(foreach pt tempPtList
(setq PtList (cons (car pt) PtList))
(setq PtList (cons (cadr pt) PtList))
)
(setq tempPline
(vlax-invoke
CurSpace
'AddLightWeightPolyline
(reverse PtList)
)
)
(vla-put-Closed tempPline :vlax-true)
(ssadd (vlax-vla-object->ename tempPline) Plss)
)
)
(setq
BasePt (apply
(function
(lambda (p1 p2)
(mapcar (function (lambda (e1 e2) (/ (+ e1 e2) 2.))) p1 p2)
)
)
((lambda (Coords)
(apply
(function
(lambda (mn mx) (mapcar (function (lambda (n x) (list n x))) mn mx))
)
(mapcar (function (lambda (c) (list (apply 'min c) (apply 'max c))))
(list (mapcar 'car Coords) (mapcar 'cadr Coords))
)
)
)
(apply
'append
(mapcar
(function (lambda (Obj)
(vla-GetBoundingBox Obj 'LL 'UR)
(list (vlax-safearray->list LL) (vlax-safearray->list UR))
)
)
ObjList
)
)
)
)
)
(if (> (sslength Plss) 0)
(progn
(setvar 'cmdecho 1)
(command "_.move"
Plss
""
BasePt
pause
)
(setq NewPt (getvar 'lastpoint))
(setvar 'cmdecho 0)
(command "_.erase" Plss "")
(foreach obj ObjList
(vlax-invoke obj 'Move (append BasePt (cddr NewPt)) NewPt)
)
)
)
(vla-EndUndoMark ActDoc)
(princ)
)
-
Resurrecting this old post
Vovka's original lisp is great for quickly moving one attribute with the minimum of clicks.
The lisp with the addition of T.Willey's code (in the post above) is great for moving multiple attributes, where you select which ones you want to move.
I would also like a lisp which would automatically select all the blocks attributes for moving after clicking on just one of the attributes, is this possible?
Fingers crossed that its just a simple modification.
Any help would be appreciated.
Thanks
-
I don't know but what about this one ?
http://www.cadtutor.net/forum/showthread.php?t=37859&highlight=leemac
-
Thanks Aerdvark but that lisps moves every attribute with the same tag.
What I am looking for is a modification of the lisp in this thread so that it automatically selects all the attributes on a selected block, instead of its current behaviour, where the attributes to be moved are selected individually.
Cheers
-
Hi
A lisp (http://www.cadxp.com/modules.php?op=modload&name=XForum&file=viewthread&tid=19155#pid79051) from (gile)
;; MOVEATT (gile) 07/05/08
;; Déplace les attributs
;; Par défaut l'utilisateur sélectionne les attributs un par un
;; L'option "Bloc" permet de déplacer tous les attributs des blocs sélectionnés
(defun c:MoveAtt
(/ space att lst1 lst2 ss1 ss2 tmp cl lay lck txt al p1 p2)
(vl-load-com)
(or *acdoc*
(setq *acdoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(initget "Bloc")
(setq att (nentsel "\nSélectionnez un attribut ou [Bloc] <Bloc>: "))
(if (or (null att) (= att "Bloc"))
(if (ssget '((0 . "INSERT") (66 . 1)))
(vlax-for blk (setq ss1 (vla-get-ActiveSelectionSet *acdoc*))
(setq lst1 (append (vlax-invoke blk 'getAttributes) lst1))
)
)
(progn
(and
(setq att (car att))
(= (cdr (assoc 0 (entget att))) "ATTRIB")
(setq lst1 (cons (vlax-ename->vla-object att) lst1))
(redraw att 3)
)
(while (setq att (car (nentsel "\nSélectionnez un attribut: ")))
(and
(= (cdr (assoc 0 (entget att))) "ATTRIB")
(setq lst1 (cons (vlax-ename->vla-object att) lst1))
(redraw att 3)
)
)
)
)
(if lst1
(progn
(vla-StartUndoMark *acdoc*)
(setq space (if (= 1 (getvar "cvport"))
(vla-get-PaperSpace *acdoc*)
(vla-get-ModelSpace *acdoc*)
)
ss2 (ssadd)
tmp (vla-add (vla-get-Layers *acdoc*) "MoveAtt_tmp")
cl (vla-get-ActiveLayer *acdoc*)
)
(vla-put-ActiveLayer *acdoc* tmp)
(foreach a lst1
(setq lay (vla-item (vla-get-Layers *acdoc*) (vla-get-Layer a)))
(and (= (vla-get-Lock lay) :vlax-true)
(setq lck (cons lay lck))
(vla-put-Lock lay :vlax-false)
)
(setq txt
(vla-addText
space
(vla-get-TextString a)
(vla-get-InsertionPoint a)
(vla-get-Height a)
)
)
(foreach prop '(Backward Linetype LinetypeScale
Normal ObliqueAngle Rotation
ScaleFactor StyleName Thickness
TrueColor UpsideDown
)
(vlax-put-property txt prop (vlax-get-property a prop))
)
(setq al (vla-get-Alignment a))
(vla-put-Alignment txt al)
(and (member al '(0 3 5))
(vla-put-InsertionPoint
txt
(vla-get-InsertionPoint a)
)
)
(or (= 0 al)
(vla-put-TextAlignmentPoint
txt
(vla-get-TextAlignmentPoint a)
)
)
(setq ss2 (ssadd (vlax-vla-object->ename txt) ss2)
lst2 (cons txt lst2)
)
)
(if
(not
(vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ()
(setq p1 (getpoint "\nSpécifiez le point de base: "))
(vl-cmdf "_.move" ss2 "" p1 pause)
(setq p2 (getvar "lastpoint"))
)
)
)
)
)
(mapcar
(function
(lambda (a)
(vla-move a
(vlax-3d-point (trans p1 1 0))
(vlax-3d-point (trans p2 1 0))
)
)
)
lst1
)
)
(vla-put-ActiveLayer *acdoc* cl)
(mapcar 'vla-delete lst2)
(vla-delete tmp)
(mapcar (function (lambda (x) (vla-put-Lock x :vlax-true)))
lck
)
(vla-EndUndoMark *acdoc*)
)
)
(princ)
)
@+
-
It's possible.
Just select the attribute,
then get the name of the block that it is associated with,
then grab all the blocks,
step through the blocks to the attribute desired,
then move said attribute.
Edit: Totally misunderstood the question, but it is possible.
Select the block,
enter distance and angle to move,
then step through the attributes and move them by distance and angle.
-
Thanks for all your answers, but I don't think I'm explaining myself very well.
I do not wish to move attributes globally, throughout the entire drawing, but instead locally one block at a time.
The 2 lisps attached do a very good job.
MOVEATTXT - moves one attribute on one block at a time, its a quick way of selecting an individual attribute and moving it without messing with grips.
MOVEATTEXT - works in a very similar way but allows the selection of more one attribute on an individual block.
I'm hoping to modify MOVEATTEXT so that it will select all the attributes on just the selected individual block, the reason being that sometimes in congested areas it can be difficult to select the attributes of a block without accidentally selecting another blocks attribute by mistake.
Thanks
Pads
-
I was inspired do little bit more :-)
(defun C:MoveAtt (/
doc
x
att
dis
rot
)
(vl-load-com)
(princ "\nMove selected Attributes")
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark doc)
(cond
((ssget (list (cons 0 "INSERT")))
(setq dis (getdist "\nType in value for move selected Attributes\n<[Up] +value> <[Down] -value>: "))
(vlax-for item (vla-get-ActiveSelectionSet doc)
(cond
((= (vla-get-HasAttributes item) :vlax-true)
(setq att (variant-value (vla-getattributes item)))
(foreach x (safearray-value att)
(setq rot (vla-get-rotation x))
(vla-put-insertionpoint x
(vlax-3d-point
(polar
(safearray-value
(variant-value
(vla-get-insertionpoint x)
)
)
(+ rot (/ pi 2)); angle in radians
dis ; distance to move
)
)
)
)
(vla-update item))
((princ "\nNo blocks in drawing"))))))
(vla-endundomark doc)
(princ)
)
(defun c:MA () (C:MoveAtt))
-
Hallo cadplayer
What does that do for me nothing happens.
Was soll das machen bei mir passiert gar nichts.
-
Try it with my block. The code changes only position from Attribute in up down direction
-
OK works
Thank you
OK funktioniert
Danke