Sunday, January 19, 2020

Rectangle Listing Autolisp

Code as below-see
https://www.youtube.com/watch?v=lus7WLJ2wJQ&feature=youtu.be

It numbers rectangles and then lists their coordintes in a comma delimited file, ie .csv

;Program written by Bill Le Couteur
;Auckland NZ
;Rev 0 date 29/11/17
;This program selects rectangles and labels them with coordinates,length, width and area
;
;

(defun  c:LR()
;(setvar "CMDECHO" 0)
(setq oldsnapmode (getvar "osmode"))
(setvar "osmode" 0)
(command "ucs" "w")
(setq the_count "500"); just a dummy so the while loop keeps going unless user escapes!
(setq count 0)
(setq SerialNo 1)
(setq SerialNos (itoa SerialNo))
(setq the_drg_path (getvar "DWGPREFIX"))
(setq the_file_name (getstring "/nEnter the file name, no prefixes or suffixes: "))
(setq the_text_height (getreal "/nEnter the text height needed: "))


(setq full_file_name (strcat the_drg_path the_file_name ".csv"))

;this makes sure the file is empty if first used!
 (if (not(equal beenthere T))
  (close (open full_file_name  "w"))
 )


;;;;;;;;;;;;;;;;;;WHILE LOOP TO GO PICK RECTANGLES ONE BY ONE;;;;;;;;;;;;

(while (not(equal the_count "1000"))
(progn

(prompt "/npick the rectangle")
(setq edata(entget(car(entsel))))                             ;getting the pline's data
(setq ename (cdr(assoc -1 edata)))
(setq the_item (cdr (assoc 0 edata))) ;IF THE USER PICKS A CIRCLE, IT IS A SIGN TO STOP NOW, IE CLOSE THE FILE
;(if (eq "CIRCLE" the_item)
; (progn
; (print "now closing")
; (close fp)
; (exit)
; )progn
;);end if

(print edata)
;you can see the points in the edata list- they are the dotted pairs that start with 10.

(foreach thing edata
  (progn
        (if(eq (car thing) 10 ); -ie only interested in the points
             (progn;if progn
(print thing)
                (if (eq count 0)(setq the_point0 thing))
(if (eq count 1)(setq the_point1 thing))
(if (eq count 2)(setq the_point2 thing))
(if (eq count 3)(setq the_point3 thing))


(setq count (+ count 1))

         );end progn
    );end if
  );end foreach progn
);end foreach

(setq xvalue1 (nth 1 the_point0))
(setq xvalue1s (rtos xvalue1 2 4))
(setq yvalue1 (nth 2 the_point0))
(setq yvalue1s (rtos yvalue1 2 4))
(setq coordsA (strcat xvalue1s "," yvalue1s))

(setq xvalue2 (nth 1 the_point1))
(setq xvalue2s (rtos xvalue2 2 4))
(setq yvalue2 (nth 2 the_point1))
(setq yvalue2s (rtos yvalue2 2 4))
(setq coordsB (strcat xvalue2s "," yvalue2s))

(setq xvalue3 (nth 1 the_point2))
(setq xvalue3s (rtos xvalue3 2 4))
(setq yvalue3 (nth 2 the_point2))
(setq yvalue3s (rtos yvalue3 2 4))
(setq coordsC (strcat xvalue3s "," yvalue3s))

(setq xvalue4 (nth 1 the_point3))
(setq xvalue4s (rtos xvalue4 2 4))
(setq yvalue4 (nth 2 the_point3))
(setq yvalue4s (rtos yvalue4 2 4))
(setq coordsD (strcat xvalue4s "," yvalue4s))


(setq header_line "Sn,Ax,Ay,Bx,By,Cx,Cy,Dx,Dy,Length,Area")
(setq the_length (- xvalue2 xvalue1))


;;;;;;;;;FOR A NORMAL RECTANGLE;;;;;;;;;;;;;;;;;;;;
(if (> the_length 0)
(progn
(setq the_lengths (rtos the_length 2 4))
(setq the_width (- yvalue3 yvalue1))
(setq insert_pointx (+ xvalue1 (/ the_length 2)))
(setq insert_pointy (+ yvalue1 (/ the_width 2)))
(setq insert_point (list insert_pointx insert_pointy))
);end if progn
);end if
;;;;;;;;END OF FOR A NORMAL RECTANGLE;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;FOR A REVERSE RECTANGLE;;;;;;;;;;;;;;;;;;;;
(if (< the_length 0)
(progn
(print "hello")
(setq the_length (* the_length -1))
(setq the_lengths (rtos the_length 2 4))
(setq the_width (- yvalue3 yvalue1))
(setq insert_pointx (- xvalue1 (/ the_length 2)))
(setq insert_pointy (+ yvalue1 (/ the_width 2)))
(setq insert_point (list insert_pointx insert_pointy))
);end if progn
);end if
;;;;;;;;END OF FOR A REVERSE RECTANGLE;;;;;;;;;;;;;;;;;;;;


(if (< the_width 0)(setq the_width (* the_width -1)))
(setq the_area (* the_length the_width))
(setq the_areas (rtos the_area))

(setq the_line (strcat SerialNos "," CoordsA ","   CoordsB ","  CoordsC ","  CoordsD "," the_lengths "," the_areas))


(setq the_text_height 300)


(setq fp (open full_file_name "a"))
(if (not(equal beenthere2 T)) (write-line header_line  fp))
(write-line the_line  fp)
(command "text" "j" "m" insert_point the_text_height 0 SerialNos)

(setq SerialNo (+ SerialNo 1))
(setq SerialNos (itoa SerialNo))

(setq beenthere2 T)

(setq count 0)

);END OF WHILE PROGN
);END OF WHILE

;;;;;;;;;;;;;;;;;;END OF WHILE LOOP TO GO PICK RECTANGLES ONE BY ONE;;;;;;;;;;;;





(close fp)
 (setq beenthere T)


(command "ucs" "w")
 ;(setvar "CMDECHO" 1)
(setvar "osmode" oldsnapmode)
(princ)
)
 

No comments: