Code:
(vl-load-com)
(defun C:RotTo (/ var ev getobj :angle2UCS ent obj ang-in ang-to)
(defun :angle2UCS (ang / ucs)
(setq ucs (- ang (angle '(0 0 0) (getvar "UCSXDIR"))))
(if (< ucs 0.) (setq ucs (+ ucs (* 2 PI))))
ucs)
(defun VAR (typ) ; build variable name with number
(read (strcat typ num))
)
(defun EV (typ) ; evaluate what's in variable name with number
(eval (read (strcat typ num)))
)
;GETOBJ from ReportAngle.LSP by Kent Cooper, 11/2011, edited for UCS
(defun GETOBJ (esel num / edata etype subedata subetype path pt1 pt2)
(while (not (and (setq edata (if esel (entget (car esel)))
etype (if esel (cdr (assoc 0 edata))))
(set (var "pick"); = pick1 or pick2
(osnap (cadr esel) "nea")); for (vlax-curve) later; also prohibits things like text elements of Dimensions
(wcmatch etype "ARC,LINE,*POLYLINE,@LINE,RAY,INSERT,HATCH,DIMENSION,LEADER,*SOLID,3DFACE,WIPEOUT,TRACE,REGION,IMAGE,VIEWPORT,TOLERANCE")
(or (wcmatch etype "ARC,*POLYLINE")
(not (osnap (ev "pick") "cen"))) ; if Polyline/Block/Region/3DSolid/angular Dimension, not on arc/ellipse segment or circle/arc/ellipse element
(cond
((= etype "INSERT")
(and (setq subedata (entget (car (nentselp (ev "pick")))) ; then, use nested object -- same checks as above, except:
subetype (cdr (assoc 0 subedata))) ; no center Osnap check [earlier check covers it] ; no Insert or heavy Polyline object types [never returned by (nentselp)]
(wcmatch subetype "LINE,LWPOLYLINE,VERTEX,@LINE,RAY,HATCH,DIMENSION,LEADER,*SOLID,3DFACE,WIPEOUT,TRACE,REGION,IMAGE,VIEWPORT,TOLERANCE")
(if (= subetype "LEADER") (= (cdr (assoc 72 subedata)) 0) T); STraight, not Splined
(if (= subetype "VERTEX") (= (boole 1 8 (cdr (assoc 70 subedata))) 0) T))); not Splined 2DPolyline
((= etype "LEADER") (= (cdr (assoc 72 edata)) 0)); STraight, not Splined
((= etype "POLYLINE") (= (boole 1 4 (cdr (assoc 70 edata))) 0)); not Splined 2DPolyline
(T)))) ; all other object types
(prompt "\nNothing selected, or not a straight object with linearity --")
(exit)); while
(cond ((wcmatch etype "ARC") ;arc
(setq path (car esel))
(set (var "ang") ; = ang1 or ang2
(angle (setq pt1 (vlax-curve-getStartPoint path))
(setq pt2 (vlax-curve-getEndPoint path))))
(grdraw (trans pt1 0 1) (trans pt2 0 1) 7 -1))
((and (wcmatch etype "*POLYLINE") ;arc segment of polyline
(osnap (ev "pick") "cen"))
(setq path (car esel))
(set (var "ang") ; = ang1 or ang2
(angle (setq pt1 (vlax-curve-getPointAtParam path (fix (vlax-curve-getParamAtPoint path (trans (ev "pick") 1 0)))))
(setq pt2 (vlax-curve-getPointAtParam path (1+ (fix (vlax-curve-getParamAtPoint path (trans (ev "pick") 1 0))))))))
(grdraw (trans pt1 0 1) (trans pt2 0 1) 7 -1))
((wcmatch etype "POLYLINE,XLINE,RAY"); vlax-curve-applicable types
(setq path (car esel))
(set (var "ang") ; = ang1 or ang2
(angle '(0 0 0)
(vlax-curve-getFirstDeriv path (vlax-curve-getParamAtPoint path (trans (ev "pick") 1 0))))))
(T
(set (var "ang") ; = ang1 or ang2
(angle (setq pt2 (trans (osnap (ev "pick") (if (= subetype "RAY") "nea" "mid")) 1 0)) ; account for Ray in Block [no midpoint]
(setq pt1 (trans (osnap (ev "pick") (if (= subetype "XLINE") "nea" "end")) 1 0)))) ; account for Xline in Block [no endpoint]
(grdraw (trans pt1 0 1) (trans pt2 0 1) 7 -1)))
(set (var "ang") (+ (ev "ang") PI))
(if (> (ev "ang") (* 2 PI)) (set (var "ang") (- (ev "ang") (* 2 PI))))
(ev "ang")
)
;; ---------------
(if (and (setq ent (ssget "_+.:E:S"))
(setq ent (ssname ent 0))
(setq obj (vlax-ename->vla-object ent))
(setq pnt (getpoint "\nReference point: "))
(or (not (vl-catch-all-error-p (setq ang-in (vl-catch-all-apply 'vla-get-rotation (list obj)))))
(setq ang-in 0.))
(or (setq ang-to (getangle "\nSpecify final angle <by object>: "))
(setq ang-to (:angle2UCS (getobj (entsel "\nSelect to aling to: ") "1"))))
)
(progn
(if (/= (cdr (assoc 0 (entget ent))) "MTEXT")
(setq ang-in (:angle2UCS ang-in)))
(command "_.ROTATE" ent "" "_none" pnt "_R" (angtos ang-in (getvar 'AUNITS) 8) (angtos ang-to (getvar 'AUNITS) 8))))
(princ)
)
Lisp modification
Reply With Quote
Originally Posted by enghezt
