Calculate the Slope

;|

       Pick POLYLINE to Calculate the Slope

       Create and Design by SONGKHRAN JONGKUL June 2021

|;

(defun tan (x) (/ (sin x)(cos x)))

(defun arsin (x) (setq y (sqrt (- 1 (* x x)))) (atan x y))

(defun arcos (x) (- (/ pi 2)(arsin x)))

(defun rtod (x) (/ (* x 180) pi))

(defun dtor (x) (* x (/ pi 180)))  

 

(defun C:slope ( / ent lst PT1);; x y z

(setq old_cmdecho  (getvar "cmdecho"))  ;  cmdecho

(setq old_osnap (getvar "osmode"))  ; osnap

(setq old_layer (getvar "clayer"))

(setvar "cmdecho" 0)

(setvar "osmode" 0)

(setq txth (getvar 'textsize))

(if (not (tblsearch "LAYER" "SLOPE-TEXT" ));;<=== Layer Name

       (command "._layer" "_M" "SLOPE-TEXT" "_Color" 5 "" "LType" "Continuous" "" "")

)

(command "._style" "SLOPE-TEXT" "RID_TE.shx" 1.00 1.00 0 "n" "n");;font name: RID_TE.shx

(setq ent (entsel "\nPick POLYLINE to calculate the slope:"))

(if

       (and ent

              (wcmatch (cdr (assoc 0 (entget (setq ent (car ent))))) "*POLYLINE") ;all types

       ) ;and

       (setq lst (PolyVert ent)) ;make list

)

(setq lstlen (length lst)

         st 0

         sn 1

)

(repeat lstlen

       (setq p1 (nth st lst);;read point p1

                p2 (nth sn lst);;read point p2

       )

       (if(or(> (cadr p1)(cadr p2))(< (cadr p1)(cadr p2)))

                     (tri p1 p2)

       )

       (setq st (1+ st)

                sn (1+ sn)

       )

);repeat

;(print lst)

(setvar "cmdecho" old_cmdecho)

(setvar "osmode" old_osnap)

(setvar "clayer" old_layer)

(princ)

)

(princ "\nEnter SLOPE to Start Calculate the Slope. ")

(princ)

(defun PolyVert (POLY / par pt1 lst)

(vl-load-com)

       (setq par

              (if (vlax-curve-isClosed POLY)

                     (vlax-curve-getEndParam POLY) ; else

                     (1+ (vlax-curve-getEndParam POLY))

              )

       )

       (while (setq pt1 (vlax-curve-getPointAtParam POLY (setq par (- par 1))))

              (setq lst (cons pt1 lst))

       )

) ; return lst

(defun tri (p1 p2 /) ;;calculate slope and draw triangle

(setq ang (angle p1 p2)

         trih (* txth 1.50)

)

(setq mp (polar p1 ang (/ (distance p1 p2) 2.0)))

(setq pta1 (polar mp (dtor 270.0) trih))

(if(< (cadr p1) (cadr p2))

       (setq Xdis (- (car p2)(car p1))

                Ydis (- (cadr p2)(cadr p1))             

       )

       (setq Xdis (- (car p2)(car p1))

                Ydis (- (cadr p1)(cadr p2))

       )

)

(setq angsl (rtod(atan(/ Ydis Xdis)))

         perc (* (/ Ydis Xdis) 100)

         ratio (/ 1 (tan (dtor angsl)))

)

(setq lb (/ trih (tan (dtor angsl))))

(if (and(> (rtod ang) 0)(< (rtod ang) 90))

       (progn

              (setq pta2 (polar pta1 (dtor 180.0) lb))

              (setq txtlr (list (+(car pta1)txth)(+(cadr pta1)(/ trih 2.0))))

              (setq txtblr (list (-(car pta1)(/ lb 2.0))(-(cadr pta1)(/ txth 2.0))))

       )

       (progn

              (setq pta2 (polar pta1 (dtor 0) lb))

              (setq txtlr (list (-(car pta1)txth)(+(cadr pta1)(/ trih 2.0))))

              (setq txtblr (list (+(car pta1)(/ lb 2.0))(-(cadr pta1)(/ txth 2.0))))

       )

)

(command "_pline" mp pta1 pta2 "c")

(myText "SLOPE-TEXT" "mc" txtlr txth 0 1 "1");angle 0 colour 1

(myText "SLOPE-TEXT" "tc" txtblr txth 0 1 (rtos ratio 2 2));angle 0 colour 1

(myText "SLOPE-TEXT" "bc" mp txth ang 1

       (strcat "Ang " (rtos angsl 2 2) "%%d"

              " Slope " (rtos perc 2 2) "%"

              " 1:"(rtos ratio 2 2)

       )

)

(princ)

);end tri

 

(defun myText (txtStyle txtJust insertPt textHeight ang col txtString)

       (if (= txtJust "L") (setq horJust 0

                                                  verJust 0));Left

       (if (= txtJust "C") (setq horJust 1

                                                  verJust 0));Center

       (if (= txtJust "R") (setq horJust 2

                                                  verJust 0));Right

                                                 

       (if (= txtJust "bl") (setq horJust 0

                                                   verJust 1));Bottom Left

       (if (= txtJust "bc") (setq horJust 1

                                                   verJust 1));Bottom Center

       (if (= txtJust "br") (setq horJust 2

                                                   verJust 1));Bottom Right

                                                  

       (if (= txtJust "ml") (setq horJust 0

                                                   verJust 2));Middle Left                                              

       (if (= txtJust "mc") (setq horJust 1

                                                   verJust 2));Middle Center

       (if (= txtJust "mr") (setq horJust 2

                                                   verJust 2));Middle Right 

                                                  

       (if (= txtJust "tl") (setq horJust 0

                                                   verJust 3));Top Left

       (if (= txtJust "tc") (setq horJust 1

                                                   verJust 3));Top Center

       (if (= txtJust "tr") (setq horJust 2

                                                   verJust 3));Top Right   

 

;(myText "AREA-TEXT" "mc" pt txth 0 col tarea)

;These values are just being used for testing

 ;(setq txtStyle "Standard")

 ;(setq insertPt (list 2.0 3.0))

 ;(setq txtString "test")

 

 (entmake

  (list

   (cons 0 "TEXT")

   (cons 100 "AcDbEntity")

   (cons 100 "AcDbText")

   (cons 7  txtStyle) ;Text style name

   (cons 10 insertPt) ;First alignment point

   (cons 11 insertPt) ;Second alignment point

   (cons 40 textHeight)

   (cons 1  txtString) ;Default value (the string itself)

   (cons 50 ang) ;Text rotation

   (cons 62 col) ;Text Colour

   (cons 71 0) ;Flags 0=Normal, 2=Backward, 4=Upside down

   (cons 72 horJust) ;Horizontal text justification,0=Left,1=Center,2=Right,4=Center,5=Fit

   (cons 73 verJust) ;Vertical text justification, 0=Baseline,1=Bottom,2=Middle,3=Top

  )

 )

)

Change Elevation Point

;|    

      Change Elevation Point

 (+ Addend) or (- Subtrahend) Elevation Point

      Create and Design by SONGKHRAN JONGKUL June 2021

      - Enter Number + Addend or - Subtrahend

      - Select Point   

|;

(defun Change_Elevation (/ symb val ss pt assoc10 Zval newZ cntr)

(if (= tmp nil) (setq tmp "-5"))

(setq inp (getstring (strcat "\nEnter Number < " tmp " > :")))

(if (= inp "")(setq inp tmp))

(setq tmp inp)

(setq symb (substr inp 1 1))

(setq val (atof(substr inp 2 )))

(prompt "\n Select Point")

(if (or (= symb "+")(= symb "-"))

      (if (setq ss (ssget '((0 . "POINT"))))

            (progn                 

                  (setq cntr 0)

                  (while (< cntr (sslength ss))

                        (setq pt(entget(ssname ss cntr)))

                        (setq assoc10 (assoc 10 pt))

                        (setq Zval(last assoc10))

                        (setq newZ (apply (read symb) (list zval val)))

                        (entmod

                              (subst

                                    (reverse (cons newZ (cdr (reverse assoc10))))

                                    assoc10

                                    pt

                              );subst

                        ); entmod

                        (setq cntr(+ cntr 1))

                  );while

            );progn

      );if

(progn

      (Alert "Please Enter Number : (+ Addend) or (- Subtrahend) and Number")

      (Change_Elevation)

);progn

);if

(princ)

);end

(defun c:chelv ()

      (Change_Elevation)

)

(prompt "\n Change Elevation Point")

(prompt "\n Enter CHELV to Start.")

Calculates Cut and Fill.

 Calculates Cut and Fill.

Quick Profile

 

Insert and Update Attribute Blocks from csv Excel File

 

Insert Block from csv Excel File.

 

;|

       Insert Block from csv Excel File. 

       - Create and Design by Songkhran Jongkul 23-04-2021

       - Add Options Coordinate Point N E Elv or X Y Z

|;

(defun c:imcsv ();(/ Deconstruct_String file st)

;;-----radial to dreegee

       (defun rtod (x)

       (/ (* x 180) pi)

       )

;;-----dreegee to radial    

       (defun dtor (x)

       (* x (/ pi 180))

       )

;;-----------------------------------------

(setq old_cmdecho  (getvar "cmdecho"))

(setq old_osnap (getvar "osmode"))

(setq old_cecolor (getvar "CECOLOR"))

(setq old_layer (getvar "clayer")) ; layer

;;-----------------------------------------

(setvar "cmdecho" 0)

(setvar "osmode" 0)

 

(setq fname "RID_TE.shx"   ;"FreesiaUPC"

         txtsty "Des_Blocks"

         txth 2.50

         lyblk "Blocks_Layer"

         lydesc "Descriptions"

         ;drawline "1"                   

)

;;-----------------------------------------

(initget "1 2")

(setq coord (getkword "\nCoordinate point Options [1 N E Elv. / 2 X Y Z] : <1> "))

(if (= coord "")(setq coord "1"))

;;-----------------------------------------

(initget "1 2 3 4")

(setq destxt (getkword "\nDescriptions Text Options[1 None. / 2 No. / 3 Descriptions / 4 No. Descriptions] : <1> "))

(if (= destxt "")(setq destxt "1"))

;;-----------------------------------------

(initget "1 2")

(setq drawline (getkword "\nOptions Draw Polyline  [1 Yes. / 2 No.] : <1> "))

(if (= drawline "")(setq drawline "1"))

;;-----------------------------------------

(if (=  drawline "1")

       (if (not (tblsearch "LAYER" "Polyline_Layer"));;<=== Layer Name

              (command "._layer" "_M" "Polyline_Layer" "_Color" "7" "" "LType" "Continuous" "" "");;<=== Layer Name

       )

)

       (if (not (tblsearch "LAYER" lyblk));;<=== Layer Name FI

              (command "._layer" "_M" lyblk "_Color" "1" "" "LType" "Continuous" "" "");;<=== Layer Name

       )

       (if (not (tblsearch "LAYER" lydesc));;<=== Layer Name

              (command "._layer" "_M" lydesc "_Color" "2" "" "LType" "Continuous" "" "");;<=== Layer Name

       )

       (if (not (tblsearch "Style" txtsty))

              ;(command "-style" "newstylename" "fontname" "textheight" "widthfactor" "0" "" "" "")

              (command "_style" txtsty fname "" "" "0" "" "") ; Fonts Thai FreesiaUPC

       )

      

(defun Deconstruct_String (st delimiter / p l)

       (while (setq p (vl-string-search delimiter st 0))

              (setq l  (cons (substr st 1 p) l)

                       st (substr st (+ p 2) (strlen st))

              )

       )

       (if st

              (setq l (cons st l))

       )

       (setq l (reverse l))

)

 

(Setq p1 nil

         ss1 nil

)

 

(if (setq file (getfiled "Select Excel file ..." "" "csv" 16))

       (progn       

              (setq file (open file "r"))

              (while (setq st (read-line file))

                     (setq st (Deconstruct_String st ";"))

                     (setq p (Deconstruct_String (car st) ",")) ;String all;0-No. 1-blkname 2-N  3-E  4-elv  5-scX 6-scY 7-Angle 8-Descriptions

                     (setq pt0 (list (read (nth 0 p))(read (nth 1 p))(read (nth 2 p))(read (nth 3 p))(read (nth 4 p))(read (nth 5 p))(read (nth 6 p))(read (nth 7 p))(read (nth 8 p))))

                     (setq lst (cons p lst))

                     (if (= (nth 8 p) "")

                           (setq desc " ")

                           (setq desc (nth 8 p))

                     )

                     (if (= coord "1")     ;N E elv or X Y Z

                           (setq pt (list (nth 3 pt0) (nth 2 pt0) (nth 4 pt0))) ;N E Elv.

                           (setq pt (list (nth 2 pt0) (nth 3 pt0) (nth 4 pt0))) ;X Y Z

                     )

                     (setq no (nth 0 p)

                             blkname (nth 1 p)

                             scX (nth 5 pt0)

                             scY (nth 6 pt0)

                              ang (nth 7 pt0)

                     )

                     (setvar "clayer" lyblk)

                     (entmake

                           (list '(0 . "INSERT")

                                  (cons 2 blkname)            ;block name

                                  (cons 10 pt)                ;insert point

                                  (cons 41 scx)               ;scale x

                                  (cons 42 scy)               ;scale y

                                  ;(cons 43 scz)               ;scale z

                                  (cons 50 (dtor ang))  ;angle radial

                           )

                     )

                     (setvar "clayer" lydesc)

                     (if (/= desc nil)

                                  (myText txtsty "ml" pt txth 0

                                         (cond

                                                ((= destxt "1")(strcat "  " ))

                                                ((= destxt "2")(strcat "  " no "." ))

                                                ((= destxt "3")(strcat "  " desc))

                                                ((= destxt "4")(strcat "  " no ". " desc))

                                         )

                                  )

                     )

                     ;;-----------draw pline------------------

                     (if (= drawline "1")

                     (progn

                           (setvar "clayer" "Polyline_Layer")

                           (if (/= p1 nil)

                                  (progn

                                         (command "_.pline" "_none" p1 "_none" pt "")

                                         (setq ss2 (entlast))

                                  )

                           )

                           (if (/= ss1 nil)

                                  (progn

                                         (command "_.pedit" "_multiple" ss1 ss2 "" "_join" "0.0" "")

                                         (setq ss2 (entlast))

                                  )

                                  (setq ss1 ss2)

                           )

                           (setq p1 pt)

                     )

                     )

                     ;;---------------------------------------

              );while

              (close file)

       );progn

(princ)

);if

(command "_zoom" "_E")

;;-----------------------------------------------------------  

(setvar "cmdecho" old_cmdecho)

(setvar "osmode" old_osnap)

(setvar "cecolor" old_cecolor)

(setvar "clayer" old_layer)

(princ)

);end defun

(prompt "\nEnter IMCSV to start. ")

(prompt "\nCreate and Design by Songkhran Jongkul 23-04-2021")

;;---------------------------------------------------

(defun myText (txtStyle txtJust insertPt textHeight ang txtString)

       (if (= txtJust "L") (setq horJust 0

                                                  verJust 0));Left

       (if (= txtJust "C") (setq horJust 1

                                                  verJust 0));Center

       (if (= txtJust "R") (setq horJust 2

                                                  verJust 0));Right

       (if (= txtJust "bl") (setq horJust 0

                                                   verJust 1));Bottom Left

       (if (= txtJust "bc") (setq horJust 1

                                                   verJust 1));Bottom Center

       (if (= txtJust "br") (setq horJust 2

                                                   verJust 1));Bottom Right                                            

       (if (= txtJust "tl") (setq horJust 0

                                                   verJust 3));Top Left

       (if (= txtJust "tc") (setq horJust 1

                                                   verJust 3));Top Center

       (if (= txtJust "tr") (setq horJust 2

                                                   verJust 3));Top Right   

       (if (= txtJust "ml") (setq horJust 0

                                                   verJust 2));Middle Left                                              

       (if (= txtJust "mc") (setq horJust 1

                                                   verJust 2));Middle Center

       (if (= txtJust "mr") (setq horJust 2

                                                   verJust 2));Middle Right

 

;These values are just being used for testing

 ;(setq txtStyle "Standard")

 ;(setq insertPt (list 2.0 3.0))

 ;(setq txtString "test")

 

 (entmake

  (list

   (cons 0 "TEXT")

   (cons 100 "AcDbEntity")

   (cons 100 "AcDbText")

   (cons 7 txtStyle) ;Text style name

   (cons 10 insertPt) ;First alignment point

   (cons 11 insertPt) ;Second alignment point

   (cons 40 textHeight)

   (cons 1 txtString) ;Default value (the string itself)

   (cons 50 ang) ;Text rotation

   (cons 71 0) ;Flags 0=Normal, 2=Backward, 4=Upside down

   (cons 72 horJust) ;Horizontal text justification,0=Left,1=Center,2=Right,4=Center,5=Fit

   (cons 73 verJust) ;Vertical text justification, 0=Baseline,1=Bottom,2=Middle,3=Top

  )

 )

)

Elevation Line

;|

       Elevation Line

       - by : AutoLispTH@hotmail.com

|;

(defun c:ELL ()

(setq old_cmdecho  (getvar "cmdecho"))

(setq old_osnap (getvar "osmode"))

(setq old_ortho (getvar "orthomode"))

(setq old_tstyle (getvar "textstyle"))

(setq old_dimzin (getvar "dimzin"))

(setq txts (getvar "textstyle"))

(setq txth (getvar "textsize"))

(setvar "cmdecho" 0)

(setvar "osmode" 0)

(setvar "dimzin" 4)

       (or st_elv (setq st_elv 10.000));start elevation

    (setq st_elvtemp

        (getdist (strcat "\n Enter Start Elevation :  <"

                        (rtos st_elv 2 3)

                                     ">: "

                ) ;_ strcat

        ) ;_ getdist

    ) ;_ setq

       (and st_elvtemp (setq st_elv st_elvtemp))

;;----------------------------------------------

       (setq sc_y 1) ;Vertical Scale

       (setvar "osmode" 33); 1=end point 32=intersection

       (setq pt1 (getpoint "\nStart Point : "))

       (setvar "osmode" 0)

       (command "_TEXT" "BL" pt1 txth "" (strcat "+" (rtos st_elv 2 3)))

       (setvar "osmode" 33)

       (while (setq pt2 (getpoint "\nElevation Point : ")) 

              (if (>= (cadr pt2)(cadr pt1))

                     (progn

                           (setq elv (*(+ st_elv (- (cadr pt2) (cadr pt1)))sc_y))

                           (setq txt (strcat "+" (rtos elv 2 3)))

                     )

                     (progn

                           (setq elv (*(- st_elv (- (cadr pt1) (cadr pt2)))sc_y))

                           (setq txt

                                  (if (<= elv 0.000)

                                         (strcat (rtos elv 2 3))

                                         (strcat "+" (rtos elv 2 3))

                                  )

                           )

                     )

              )

              (setvar "osmode" 0)

              (command "_TEXT" "BL" pt2 txth "" txt)

              (setvar "osmode" 33); 1=end point 32=intersection

       );while

 

(setvar "cmdecho" old_cmdecho)

(setvar "osmode" old_osnap)

(setvar "orthomode" old_ortho)

(setvar "textstyle" old_tstyle)

(setvar "dimzin" old_dimzin)

(princ)

)

(prompt "\nEnter ELL to Start Elevations Line.")

Circle to Dimond C2DM

 

;|

      - Circle to Dimond

      - Create by Songkhran Jongkul 19 March 2021

      - https://www.facebook.com/groups/AutolispTH

|;

(defun c:c2dm ( / e i ss)

(setq old_cmdecho  (getvar "cmdecho"))

(setq old_osnap (getvar "osmode"))

(setq old_layer (getvar "clayer"))            ; layer

(setvar "cmdecho" 0)

(setvar "osmode" 0) 

    (if (setq ss (ssget "_:L" '((0 . "CIRCLE"))))

        (progn

                  (repeat (setq i (sslength ss))                 

                        (setq e (ssname ss (setq i (1- i)))

                                ly (cdr(assoc 8  (entget e)))     ;layer name

                                ct (cdr(assoc 10 (entget e)))     ;center point

                                rd (cdr(assoc 40 (entget e)))     ;radial                  

                        )

                        (command "_erase" e "")

                        (setq dm1 (list (-(car ct) rd)(cadr ct))

                                dm2 (list (+(car ct) rd)(cadr ct))

                                dm3 (list (car ct)(+(cadr ct)(* rd 1.50)))

                                dm4 (list (car ct)(-(cadr ct)(* rd 1.50)))

                        )

                        (setvar "clayer" ly)

                        (command "_pline" dm1 dm3 dm2 dm4 "c")      

                  )

            )

    )

(setvar "cmdecho" old_cmdecho)

(setvar "osmode" old_osnap)

(setvar "clayer" old_layer)  

(princ)

)

(prompt "\nEnter C2DM to start. ")