I've always wanted autoCAD to have this function natively.
I still have to hit some angles. I believe I have the Clockwise-p function.
If you could help me fix it, I'd be grateful.
Thanks to member PKENEWELL for encouraging me to learn about the GRREAD function.
If he had not made a constructive criticism at the time, i would not have expanded my knowledge, but of course I am far from the quality of the people here.
You have a good start Augusto. I would recommend strongly however you learn how to do entity modification using the entity list and ENTMOD, or using VLA-Object modification rather than repeating a command sequence in the GRREAD loop. Your current method is slow and very inefficient. There is also a number of other things that must be emulated in a GRREAD loop to make the program viable to other users, such as object snaps and function keys etc. I'm sorry I currently do not have time to play more with your code and give you an example. Keep learning and experimenting with the code and you will progress.
To give you something to try out: This is a function I created to emulate Function keys while working in a GRREAD loop.
(defun c:test()
(vl-load-com)
;otrack
;;; https://www.theswamp.org/index.php?topic=12813.msg369811#msg369811
;;; Add MText to drawing
;;; Alan J. Thompson, 05.23.09
(defun AT:MText (#InsertionPoint #String #Width #Layer #Justification / #Width
#Space #Insertion #Object
)
(or #Width (setq #Width 0))
(or *AcadDoc*
(setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ or
(setq #Space (if (or (eq acmodelspace
(vla-get-activespace *AcadDoc*)
) ;_ eq
(eq :vlax-true (vla-get-mspace *AcadDoc*))
) ;_ or
(vla-get-modelspace *AcadDoc*)
(vla-get-paperspace *AcadDoc*)
) ;_ if
#Insertion (cond
((vl-consp #InsertionPoint) (vlax-3d-point #InsertionPoint))
((eq (type #InsertionPoint) 'variant) #InsertionPoint)
(T nil)
) ;_ cond
) ;_ setq
;; create MText object
(setq #Object (vla-addmtext #Space #Insertion #Width #String))
;; change layer, if applicable
(and #Layer
(tblsearch "layer" #Layer)
(vla-put-layer #Object #Layer)
) ;_ and
;; change justification & match insertion point with new justification
(cond ((member #Justification (list 1 2 3 4 5 6 7 8 9))
(vla-put-attachmentpoint #Object #Justification)
(vla-move #Object
(vla-get-InsertionPoint #Object)
#Insertion
) ;_ vla-move
)
) ;_ cond
#Object
) ;_ defun
;;; Quick Text
;;; Required Subroutines: AT:Mtext AT:Getstring
;;; Alan J. Thompson, 09.23.09
(defun c:QT (/ #Point1 #Point2 #String #Text #Final)
(setq #String "orthogonal track")
(setq #Point1 '(0.0 0.0 0.0))
(setq #Point2 #Point1)
(setq #Text (AT:Mtext #Point1 QT:Default 0 nil 5))
(while (eq 5 (car (setq #Final (grread T 4 4))))
(redraw)
(setq pt2 (cadr #Final))
(if
(vl-some
(function
(lambda (pt)
(setq pt1 pt)
(setq ang (angle pt1 pt2))
(setq listAngles (list ang))
(setq listAngles
(vl-sort
(append listAngles orthogonalAngles)
'<
) ;_ >vl-sort
) ;_ >setq
(if (= position 0)
(setq before (last listAngles))
(setq before (nth (- position 1) listAngles))
) ;_ >if
(if (= ang (last listAngles))
(setq after (car listAngles))
(setq after (nth (+ position 1) listAngles))
) ;_ >if
(cond
((<=
(abs
(- ang before)
) ;_ >abs
magneticFactor
) ;_ ><=
(setq ang before) ;_ >setq
)
((<=
(abs
(- ang after)
) ;_ >abs
magneticFactor
) ;_ ><=
(setq ang after)
)
(t nil)
) ;_ >cond
) ;_ >lambda
) ;_ >function
objectPoints
) ;_ >vl-some
(progn
(grdraw pt1 (setq pt2 (polar pt1 ang (distance pt1 pt2))) 1)
(vla-put-insertionpoint
#Text
(vlax-3d-point (trans pt2 1 0))
) ;_ >vla-put-insertionpoint
) ;_ >progn
(vla-put-insertionpoint
#Text
(vlax-3d-point (trans (cadr #Final) 1 0))
) ;_ >vla-put-insertionpoint
) ;_ >if
) ;_ while
(princ)
) ;_ defun
;; Unique - Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique (l)
(if l
(cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))
) ;_ >if
) ;_ >defun
; converts degrees to radians
(defun deg2rad(d) (* pi (/ d 180.0)))
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))
(setq modelSpace (vla-get-ModelSpace doc))
(setq objectPoints '())
(vlax-for obj (vla-get-ModelSpace doc)
(cond
((= (vla-get-ObjectName obj) "AcDbLine")
(setq objectPoints
(append
objectPoints
(list
(vlax-safearray->list
(vlax-variant-value (vla-get-StartPoint obj))
) ;_ >vlax-safearray->list
) ;_ >list
(list
(vlax-safearray->list
(vlax-variant-value (vla-get-endPoint obj))
) ;_ >vlax-safearray->list
) ;_ >list
) ;_ >append
) ;_ >setq
)
((= (vla-get-ObjectName obj) "AcDbCircle")
(setq objectPoints
(append
objectPoints
(list
(vlax-safearray->list
(vlax-variant-value (vla-get-Center obj))
) ;_ >vlax-safearray->list
) ;_ >list
) ;_ >append
) ;_ >setq
)
) ;_ >cond
) ;_ >cond
(setq objectPoints (LM:Unique objectPoints)
orthogonalAngles '(0.0 1.5708) ;3.14159 4.71239
magneticFactor (deg2rad 2) ;to simulate magnetic
) ;_ >setq
(c:QT)
)