TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: HasanCAD on September 23, 2010, 05:58:40 AM
-
I am trying to write a lisp to rotate selected objects but keep the text in the same angle
I did rotation step
But how to filter the previous selectionset to select text and mtext
Then rotate from its basepoint at opposite direction
Thanks
(defun c:PlanRotate ( / AcObj ActDoc
SelectoinPoint1 SelectoinPoint2 SelectionSet BasePoint RotationAngle RotationAngleDtr
)
(vl-load-com)
;Undo
(setq AcObj (vlax-get-Acad-Object))
(setq ActDoc (vla-get-ActiveDocument AcObj))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
(if
(and
(setq SelectoinPoint1 (getpoint "\nSpecify first corner point: "))
(setq SelectoinPoint2 (getcorner SelectoinPoint1 "\nSpecify second corner point: "))
(setq SelectionSet (ssget "c" SelectoinPoint1 SelectoinPoint2))
(setq BasePoint (getpoint "\nSpecify Base Point for Rotation: "))
(setq RotationAngle (getangle BasePoint "\nSpecify Rotation angle: "))
(setq RotationAngleDtr (* (/ RotationAngle pi) 180.0))
)
(progn
(command "_.ROTATE" SelectionSet "" BasePoint RotationAngleDtr)
)
(princ "\n No objects selected")
)
;(foreach n '(a b c) (print n))
(vla-EndUndoMark ActDoc)
(princ)
)
[edit:kdub]Title was 'Help with this lisp'
-
I'd try something like this:
(defun c:PlanRot (/ p1 p2 ss bp ra i en ed)
(initget 1)
(setq p1 (getpoint "\nFirst Corner: "))
(initget 1)
(setq p2 (getcorner p1 "\nOpposite Corner: "))
(if (not (setq ss (ssget "_C" p1 p2 '((0 . "*TEXT")))))
(progn (alert "No Text Entities Found")
(exit)))
(initget 1)
(setq bp (getpoint "\nRotation Base Point: "))
(initget 3)
(setq ra (getangle "\nRotation Angle: "))
(command "_.ROTATE" ss "" bp (/ (* ra 180.0) pi))
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
(setq ed (entget en))
(entmod (subst (cons 50 (- (cdr (assoc 50 ed)) ra)) (assoc 50 ed) ed)))
(prin1))
-David
-
I am trying to write a lisp to rotate selected objects but keep the text in the same angle
(defun c:PlanRotate ( / AcObj ActDoc
SelectoinPoint1 SelectoinPoint2 SelectionSet BasePoint RotationAngle RotationAngleDtr
)
(vl-load-com)
;Undo
(setq AcObj (vlax-get-Acad-Object))
(setq ActDoc (vla-get-ActiveDocument AcObj))
[color=red](vla-EndUndoMark ActDoc)[/color]
[color=blue] (vla-StartUndoMark ActDoc)
[/color]
End the undomark before it's going to start. :lmao:
otherwise it must be included with error trap functions. :ugly:
Good luck with your long routine, although your idea should not include more than four or five lines of codes.
Tharwat
-
After rereading your OP, I'd revise it to this:
(defun c:PlanRot (/ p1 p2 ss sst bp ra i en ed)
(while (not ss)
(initget 1)
(setq p1 (getpoint "\nFirst Corner: "))
(initget 1)
(setq p2 (getcorner p1 "\nOpposite Corner: "))
(setq ss (ssget "_C" p1 p2)))
(initget 1)
(setq bp (getpoint "\nRotation Base Point: "))
(initget 3)
(setq ra (getangle "\nRotation Angle: "))
(command "_.ROTATE" ss "" bp (/ (* ra 180.0) pi))
(and (setq i -1 sst (ssget "_C" p1 p2 '((0 . "*TEXT"))))
(while (setq en (ssname sst (setq i (1+ i))))
(setq ed (entget en))
(entmod (subst (cons 50 (- (cdr (assoc 50 ed)) ra)) (assoc 50 ed) ed))))
(prin1))
-David
-
Following David's lead I would code it this way.
(defun c:PlanRot (/ ss bp ra i en ed)
(prompt "\nSelect text to rotate.")
(if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
(progn
(initget 1)
(setq bp (getpoint "\nRotation Base Point: "))
(initget 3)
(setq ra (getangle bp "\nRotation Angle: "))
(command "_.ROTATE" ss "" bp (/ (* ra 180.0) pi))
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
(setq ed (entget en))
(entmod (subst (cons 50 (- (cdr (assoc 50 ed)) ra)) (assoc 50 ed) ed))
)
)
(alert "No Text Entities Found")
)
(prin1)
)
-
DAVID
CAB
Thanks
What I want is rotate selection set of objects then filter the text and rotate in opposite direction
This is revised
;;----------------=={ Rotate plan }==-------------------------;;
;; ;;
;; rotate all selected objected with apilaty of excuding ;;
;; even Text Or Blocks ;;
;;------------------------------------------------------------;;
;; Author: Hasan Mohamed Asos, 2010 ;;
;; ;;
;; Copyright © 2010 by Hasan, All Rights Reserved. ;;
;; Contact: HasanCAD @ TheSwamp.org, ;;
;; Asos2000 @ CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; ;;
;;------------------------------------------------------------;;
;; Returns: ;;
;; ;;
;;------------------------------------------------------------;;
(defun c:PlanRotate (/ Slctd
Slcnpt1 Slcnpt2 SlcnSetAll SlcnSetSlctd bspt RtnAngle Cntr
SlcnSetSlctd SlcnSetSlctd2 SlcnSetSlctd3
)
(vl-load-com)
;; © Hasan Asos 2010
(progn
(setq AcObj (vlax-get-Acad-Object))
(setq ActDoc (vla-get-ActiveDocument AcObj))
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)
)
(progn
(initget 0 "Text Blocks")
(if (> 5 (strlen (getkword "\nObjects to be executed [Text/Blocks]")))
(setq Slctd "*TEXT")
(setq Slctd "INSERT")
)
)
(if
(and
(setq Slcnpt1 (trans (getpoint "\nSpecify first corner point: ") 1 0))
(setq Slcnpt2 (trans (getcorner Slcnpt1 "\nSpecify second corner point: ") 1 0))
(setq SlcnSetAll (ssget "c" Slcnpt1 Slcnpt2))
(setq SlcnSetSlctd (ssget "c" Slcnpt1 Slcnpt2 (List (cons 0 Slctd))))
(setq bspt (trans (getpoint "\nSpecify Base Point for Rotation: ") 1 0))
(setq RtnAngle (getangle bspt "\nSpecify Rotation angle: "))
(setq Cntr -1)
)
(progn
(command "_.ROTATE" SlcnSetAll "" bspt (* (/ RtnAngle pi) 180.0))
)
(princ "\n No objects selected")
)
(while (setq SlcnSetSlctd2 (ssname SlcnSetSlctd (setq Cntr (1+ Cntr))))
(setq SlcnSetSlctd3 (entget SlcnSetSlctd2))
(entmod (subst (cons 50 (- (cdr (assoc 50 SlcnSetSlctd3)) RtnAngle)) (assoc 50 SlcnSetSlctd3) SlcnSetSlctd3))
)
(vla-EndUndoMark ActDoc)
(princ)
)
-
Nice code header lol :-D Now where have I seen that before..
-
I am trying to write a lisp to rotate selected objects but keep the text in the same angle
(defun c:PlanRotate ( / AcObj ActDoc
SelectoinPoint1 SelectoinPoint2 SelectionSet BasePoint RotationAngle RotationAngleDtr
)
(vl-load-com)
;Undo
(setq AcObj (vlax-get-Acad-Object))
(setq ActDoc (vla-get-ActiveDocument AcObj))
[color=red](vla-EndUndoMark ActDoc)[/color]
[color=blue] (vla-StartUndoMark ActDoc)
[/color]
End the undomark before it's going to start. :lmao:
otherwise it must be included with error trap functions. :ugly:
Good luck with your long routine, although your idea should not include more than four or five lines of codes.
Tharwat
I do this type of thing all the time. It is in case someone left an undo mark open.
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
-
I do this type of thing all the time. It is in case someone left an undo mark open.
I do agree but things like this with defun error.
(vl-load-com)
(defun *error* (msg)
(vla-endundomark Mycad)
(princ msg)
)
....... doing of routine ....
(vla-startundomark
(setq Mycad (vla-get-activedocument (vlax-get-acad-object)))
)
Tharwat
-
I think we discussed this recently...
My entry:
(if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndomark doc))
(vla-StartUndoMark doc)
-
DAVID
CAB
Thanks
What I want is rotate selection set of objects then filter the text and rotate in opposite direction
OH :roll:
No error checking.
(defun c:PlanRot (/ ss bp ra i en ed)
(prompt "\nSelect objects to rotate.")
(if (setq ss (ssget))
(progn
(initget 1)
(setq bp (getpoint "\nRotation Base Point: "))
(initget 3)
(setq ra (getangle bp "\nRotation Angle: "))
(command "_.ROTATE" ss "" bp (/ (* ra 180.0) pi))
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
(if (vl-position (cdr (assoc 0 (setq ed (entget en)))) '("TEXT" "MTEXT"))
(entmod (subst (cons 50 (- (cdr (assoc 50 ed)) ra)) (assoc 50 ed) ed))
)
)
)
(alert "No Text Entities Found")
)
(prin1)
)
-
I do this type of thing all the time. It is in case someone left an undo mark open.
I do agree but things like this with defun error.
(vl-load-com)
(defun *error* (msg)
(vla-endundomark Mycad)
(princ msg)
)
....... doing of routine ....
(vla-startundomark
(setq Mycad (vla-get-activedocument (vlax-get-acad-object)))
)
Tharwat
That only closes your undo marking. What about other people's code? I use code written by others in my company, an others that they farm work out to, so I just assume one is open and close it at the beginning of my code, just to make sure.
I think we discussed this recently...
My entry:
(if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndomark doc))
(vla-StartUndoMark doc)
You're correct sir. Good alternative to just closing the mark.
-
Nice code header lol :-D Now where have I seen that before..
eeemmmm
same is here I am wondering
Where have I seen that before ;)
-
I think we discussed this recently...
My entry:
(if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndomark doc))
(vla-StartUndoMark doc)
Good stuff.
-
I know it's not VL, but I think this is still the only true way of insuring a start of an undo group.
;++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
(command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
(command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 8) 8)
(command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))
-David
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
Then I guess we all flatter each other. :-)
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
Then I guess we all flatter each other.
Frequently :-)
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
Then I guess we all flatter each other.
Frequently :-)
I do find it rather ironic who first pointed out any 'possible copying'. :lol:
-
Certainly. ;-)
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
Then I guess we all flatter each other.
Frequently :-)
I do find it rather ironic who first pointed out any 'possible copying'. :lol:
Me?
-
Nice code header lol :-D Now where have I seen that before..
Yaaa Undoubtedly copied and pasted as he used to do with a little changes to become different somehow from the following link.
Although that new user with lisp would like to become a legendary with header but without being able to write their won
codes without a help for each line. :-D
http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount (http://www.cadtutor.net/forum/showthread.php?48790-Upgraded-BCount)
Imitation is the sincerest form of flattery... keep telling myself that :-)
Then I guess we all flatter each other.
Frequently :-)
I do find it rather ironic who first pointed out any 'possible copying'. :lol:
Me?
No. (no sarcasm)
-
I guess that was just me once before with that long tragedy conversations. :lmao: