Author Topic: line regularize lisp problem  (Read 242 times)

0 Members and 1 Guest are viewing this topic.

dussla

  • Bull Frog
  • Posts: 286
line regularize lisp problem
« 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.")

Pad

  • Bull Frog
  • Posts: 330
Re: line regularize lisp problem
« Reply #1 on: June 06, 2022, 12:59:21 PM »
Edit:  The Kent lisp works well, but you need to make sure the base angle in the units direction is set to East.

Code: [Select]
;
; 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:

Code: [Select]
;; 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)
)
« Last Edit: June 06, 2022, 01:30:21 PM by Pad »

dussla

  • Bull Frog
  • Posts: 286
Re: line regularize lisp problem
« Reply #2 on: June 06, 2022, 11:15:08 PM »
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
« Last Edit: June 06, 2022, 11:18:25 PM by dussla »