TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: dussla on June 06, 2022, 10:47:06 AM
-
hi i found this lisp .
this is kent cooper lisp , thank you
i test this lisp.
but result is other.
pls can you explain and fix ?
;; LinesRegularizeAngles.lsp [command name: LRA]
;; To Regularize all selected Lines, changing the Angle of each to the nearest
;; multiple of the specified angular increment. Rotates each Line around its
;; midpoint, to stay at "average" original location and at original length.
;;
;; Kent Cooper, November 2009
(defun C:LRA
(/ *error* cmde aunit osm blips anginc lines sstemp plpcs plpc
ln lndata lnend1 lnend2 lnmid lnang lnangnew)
;
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort"))
(princ (strcat "\nError: " errmsg))
); end if
(command)
(setvar 'aunits aunit)
(setvar 'osmode osm)
(setvar 'blipmode blips)
(setvar 'clayer curlay)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); end defun - *error*
;
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq
aunit (getvar 'aunits)
osm (getvar 'osmode)
blips (getvar 'blipmode)
curlay (getvar 'clayer)
anginc (getangle "\nRegularize Lines to nearest multiple of what angle? ")
); end setq
(setvar 'osmode 0)
(setvar 'blipmode 0)
(setvar 'aunits 3); radians
;
(initget "Yes No")
(if
(=
(getkword "\nExplode Polylines and process Line segments? [Y/N] <Y>: ")
"No"
); end =
(setq lines (ssget '((0 . "LINE")))); then - only Lines
(progn ; else - also Polylines, explode and add line segments to set
(setq
sstemp (ssget '((0 . "LINE,*POLYLINE")))
lines (ssadd)
); end setq
(repeat (sslength sstemp)
(setq item (ssname sstemp 0))
(ssdel item sstemp)
(if (= (cdr (assoc 0 (entget item))) "LINE")
(ssadd item lines); then - add to set of Lines
(progn; else - it's a Polyline: explode, add resulting Lines to set
(command "_.explode" item)
(setq plpcs (ssget "_P"))
(repeat (sslength plpcs)
(setq plpc (ssname plpcs 0))
(if (= (cdr (assoc 0 (entget plpc))) "LINE") (ssadd plpc lines))
(ssdel plpc plpcs)
); end repeat
); end progn
); end if
); end repeat
); end progn - else
); end if
;
(initget "Original New")
(if
(=
(getkword "\nRegularize Original lines or copies on New layer? [O/N] <O>: ")
"New"
); end =
(command
"_.layer" "_make" "ReguLines" "_color" 200 "" "" ; [change name & color number as desired]
"_.copy" lines "" '(0 0 0) '(0 0 0)
"_.chprop" lines "" "_layer" "ReguLines" ""
); end command
); end if
;
(repeat (sslength lines)
(setq
ln (ssname lines 0)
lndata (entget ln)
lnend1 (cdr (assoc 10 lndata))
lnend2 (cdr (assoc 11 lndata))
lnang (angle lnend1 lnend2)
lnmid (mapcar '/ (mapcar '+ lnend1 lnend2) '(2 2 2))
lnangnew
(if (zerop anginc)
0
(* (fix (+ (/ lnang anginc) 0.5)) anginc)
); end if & lnangnew
); end setq
(command "_.rotate" ln "" lnmid "_reference" lnang lnangnew)
(ssdel ln lines)
); end repeat
;
(setvar 'aunits aunit)
(setvar 'osmode osm)
(setvar 'blipmode blips)
(setvar 'clayer curlay)
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun
;
(prompt "\nType LRA to adjust Lines to Regularized Angles.")
-
Edit: The Kent lisp works well, but you need to make sure the base angle in the units direction is set to East.
;
; Lisp to modify drawing so East is 0 and clockwise angles, for some lisp routines
; to work correctly.
;
; P Bourke (360 Geomatics) 07/04
;------------------------------------------------------------------------
(defun C:met-e0 ()
(setvar "CMDECHO" 0)
; change direction to 0 and clockwise to n
(command "units" "" "" "" "" "0" "n")
(prompt "\n East = 0")
(setvar "CMDECHO" 1)
(princ)
)
could try this from CAB:
;; CAB 12.02.09
;; Correct angles for lines with angles near 15 and 22.5 degrees +/- fuzz
;; Only LINES & only in Current Space
;; Only UnLocked Layers
(defun c:ortholines (/ filter ss layobj i ent lst angles fuzz obj ang midpt)
(vl-load-com)
(setq angles '(15 22.5) ; degree angles to test (0 through 90)
fuzz 3.5
) ; degree tolerance for adjustments of lines
(setq angles (mapcar (function (lambda (x) (/ (* x pi) 180.0))) angles)) ; convert to radians
(setq fuzz (/ (* fuzz pi) 180.0)) ; convert to radians
;; filter locked layers
(setq filter "")
(vlax-for layobj (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(if (= (vla-get-lock layobj) ':vlax-true)
(setq filter (strcat filter (vla-get-name layobj) ","))
)
)
(and (= filter "") (setq filter "*"))
(setq ss (ssget ;| "_X" |;
(list '(0 . "LINE") (cons 8 filter) (cons 410 (getvar "ctab")))
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setq i -1)
(while (setq ent (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object ent))
(setq ang (vla-get-angle obj))
(if (and (or (equal (setq re (rem ang (cadr angles))) 0.0 fuzz)
(and (equal (setq re (rem ang (cadr angles))) (cadr angles) fuzz)
(setq re (- re (cadr angles)))
)
(equal (setq re (rem ang (car angles))) 0.0 fuzz)
(and (equal (setq re (rem ang (car angles))) (car angles) fuzz)
(setq re (- re (car angles)))
)
)
(not (zerop re))
)
(progn
(setq midpt (mapcar '(lambda (a b) (/ (+ a b) 2.))
(vlax-get obj 'startpoint)
(vlax-get obj 'endpoint)
)
)
(vla-rotate obj (vlax-3d-point midpt) (- re))
)
)
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(princ)
)
-
hi
thank you for good answer really
i tested with (east 0) again
pls can i ask again ?
I want to fix the angle to fit the angle of the bounding box
can you see attahed file