Community

combine two lisps for curves

combine two lisps for curves

mohummed.dala
Explorer Explorer
1,289 Views
11 Replies
Message 1 of 12

combine two lisps for curves

mohummed.dala
Explorer
Explorer
‎02-12-2019 05:54 AM

Hello everyone,

 

I need help combining two lisps.

 

one of the lisps generate a list of coordinates: (x and y)

BC (beginning of curve)

CC (radius point)

EC (end of curve)

PI (tangent intersection)

 

The output of this lisp is to a csv file on my documents

 

The second lisp generates RITA:

R= Radius

I= Angle

T= Tangent Length

A= Arc length

 

The output of this list goes to a model space as a text 

 

Please can you assist with creating one central file that exports multiple arc data to one csv file so that i can tabulate it as follows.

 

HEADING: REF, Y CO-ORD, X-CO ORD, DATA

BC, generated co-ordinate y, generated co-ordinate x, R= generated radius

CC, generated co-ordinate y, generated co-ordinate x, I= generated internal angle

EC, generated co-ordinate y, generated co-ordinate x, T= generated tangent length

PI, generated co-ordinate y, generated co-ordinate x, A= generated arc length

 

Many thanks

 

 

 

 

 

test 10.LSP
rita.LSP
0 Likes
Like
Report
1,290 Views
11 Replies
Replies (11)
Message 2 of 12

CADaSchtroumpf
Advisor
Advisor
‎02-12-2019 08:25 AM

Hello,

This combining is correct?

(vl-load-com)
(defun c:DALA ( / js n AcDoc Space ename obj pr nb typ_obj oldim oldlay a_base a_dir
 pt_start pt_end pt_cen rad alpha pt_vtx dist_start dist_end seg_len seg_bulge)
  (defun add_mt_arc ( / )
(write-line (strcat "BC,"(rtos (car pt_start) 2 8) "," (rtos (cadr pt_start) 2 8) "," (rtos (caddr pt_start) 2 8) "," (rtos rad 2 8)) file)
(write-line (strcat "CC,"(rtos (car pt_cen) 2 8) "," (rtos (cadr pt_cen) 2 8) "," (rtos (caddr pt_cen) 2 8) "," (angtos (- pi (* 2 alpha)) 0 4) "°") file)
(write-line (strcat "EC,"(rtos (car pt_end) 2 8) "," (rtos (cadr pt_end) 2 8) "," (rtos (caddr pt_end) 2 8) "," (rtos (distance pt_start pt_vtx) 2 8)) file)
(write-line (strcat "PI,"(rtos (car pt_vtx) 2 8) "," (rtos (cadr pt_vtx) 2 8) "," (rtos (caddr pt_vtx) 2 8) "," (rtos seg_len 2 8)) file)
  )
  (princ "\nSélectionner des Arcs/PolyArcs .")
  (setq
    js
    (ssget
      '((-4 . "<OR")
        (-4 . "<AND")
          (0 . "POLYLINE")
          (-4 . "<NOT")
            (-4 . "&") (70 . 126)
          (-4 . "NOT>")
        (-4 . "AND>")
        (0 . "LWPOLYLINE,ARC")
        (-4 . "OR>"))
    )
    n -1
  )
  (cond
    (js
      (setq
        AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
        Space
          (if (= 1 (getvar "CVPORT"))
            (vla-get-PaperSpace AcDoc)
            (vla-get-ModelSpace AcDoc)
          )
        nb 0
      )
      (cond
        ((null (tblsearch "LAYER" "Info ARTDB des Arcs"))
          (vlax-put (vla-add (vla-get-layers AcDoc) "Info ARTDB des Arcs") 'Color "5")
        )
      )
      (setq
        oldim (getvar "dimzin")
        oldlay (getvar "clayer")
        a_base (getvar "ANGBASE")
        a_dir (getvar "ANGDIR")
      )
      (setvar "dimzin" 0) (setvar "clayer" "Info ARTDB des Arcs")
      (setvar "ANGBASE" 0) (setvar "ANGDIR" 0)
		 (setq file (open (strcat (getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) "-CooExport.csv") "a"))
		 (write-line "REF,X,Y,DATA," file)
      (repeat (sslength js)
        (setq
          ename (ssname js (setq n (1+ n)))
          obj (vlax-ename->vla-object ename)
          pr -1
          nb 0
        )
        (setq typ_obj (vla-get-ObjectName obj))
        (if (eq typ_obj "AcDbArc")
          (progn
            (setq
              pt_start (vlax-get obj 'StartPoint)
              pt_end (vlax-get obj 'EndPoint)
              pt_cen (vlax-get obj 'Center)
              rad (vlax-get obj 'Radius)
              alpha (* (vlax-get obj 'TotalAngle) 0.5)
              seg_len (vlax-get obj 'ArcLength)
              pt_vtx (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))
              nb (1+ nb)
            )
            (add_mt_arc)
          )
          (repeat (fix (vlax-curve-getEndParam obj))
            (setq
              dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))
              dist_end (vlax-curve-GetDistAtParam obj (1+ pr))
              pt_start   (vlax-curve-GetPointAtParam obj pr)
              pt_end (vlax-curve-GetPointAtParam obj (1+ pr))
              seg_len (- dist_end dist_start)
              seg_bulge (vla-GetBulge obj pr)
            )
            (if (not (zerop seg_bulge))
              (progn
                (setq
                  rad (/ seg_len (* 4.0 (atan seg_bulge)))
                  alpha (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))
                  pt_cen (polar pt_start alpha rad)
                  pt_vtx (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
                  alpha (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))
                  nb (1+ nb)
                )
                (add_mt_arc)
              )
            )
          )
        )
      )
      (close file)
      (princ (strcat "\nFile exported: "(getvar 'DWGPREFIX) (vl-string-right-trim ".dwg" (getvar 'DWGNAME)) "-CooExport.csv"))
      (setvar "dimzin" oldim) (setvar "clayer" oldlay)
      (setvar "ANGBASE" a_base) (setvar "ANGDIR" a_dir)
    )
  )
  (prin1)
)

 

0 Likes
Like
Report
Message 3 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-13-2019 12:24 AM
Good morning, @CADaSchtroumpf ,
IT IS POSSIBLE TO ADJUST THIS LISP, AND ADD 2 SUBROUTINES BECAUSE IT IS VERY SIMILAR TO THIS 
 
(vl-load-com)
(DEFUN C:TG () (C:ROAD))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ROAD ( / *error* c_doc spc sv_lst sv_vals nw_style nw_font HTX ss o_type pr pt_start
  pt_end seg_len seg_bulge rad alpha m_pt t_ang t_str nw_obj ll ur att_pt t_width
       TOTAL_LINE TOTAL_ARC file File_Text);put temp variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun *error* ( msg )
  (mapcar 'setvar sv_lst sv_vals)
  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
  (princ)
 );end_*error*_defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;ADD LISP01
; CHMARKS
; =======
; Description:
; ============
; Draw chainage marks (e.g. "100.000 -") at regular intervals along source polyline
; Global Variables:
; =================
; chainage_chatstart = chainage value at start of polyline
; chainage_reginterval = regular interval between chainage marks
; chainage_markstyle = how to display chainage 1 = n.nnn 2 = n+nn 3 = n+nn.nn
; Internal Variables:
; ===================
; l1 = source polyline parsed list
; n1 = chainage value at start of polyline
; n2 = chainage mark line length
; r1 = regular interval between chainage marks
; s1 = chainage mark number style
; n3 = chainage of initial and then current chainage mark
; n4 = chainage at end of polyline
(defun C:CHMARKS (/ l1 n1 n2 r1 s1 n3 n4)
 (chainage_atstart)
; get user to select lightweight polyline (nil if polyline not selected)
 (if (/= (setq l1 (chainage_selectpline)) nil)
  (progn
; get chainage value at start of polyline, setting it to global value (or zero) if no value entered
   (setq n1 (chainage_getglobalvalue "\nEnter chainage value at start of polyline"
             chainage_chatstart 0.0 nil))
   (setq chainage_chatstart n1)
; set chainage mark line length
   (setq n2 (getvar "TEXTSIZE"))
; get regular interval between chainage marks (ensure it's not less than 1.0)
   (setq r1 (chainage_getglobalvalue "\nEnter interval between chainage marks (min. interval of 1.0)"
             chainage_reginterval 10.0 nil))
   (if (< r1 1.0)
    (setq r1 1.0)
   )
   (setq chainage_reginterval r1)
; get chainage mark number style
   (setq s1 (chainage_getglobalvalue "\nEnter chainage mark style (1=n.nnn 2=n+nn 3=n+nn.nn)"
             chainage_markstyle 1 T))
   (if (or (< s1 1) (> s1 3))
    (setq s1 1)
   )
   (setq chainage_markstyle s1)
; calculate start chainage to next regular interval after start of polyline
   (setq n3 (- n1 (rem n1 r1)))
   (if (< n3 n1)
    (setq n3 (+ n3 r1))
   )
; get overall length of polyline
   (setq n4 (+ n1 (parse_polyline_getlen l1)))
; keep looking until past end of polyline
   (while (<= n3 n4)
; draw chainage mark
    (chmark_draw l1 n1 n3 s1 n2)
; increase chainage by regular interval
    (setq n3 (+ n3 r1))
   )
   (princ "\nCommand finished")
  )
 )
 (chainage_atend)
 (princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;LISP 02 - FOR DRAWING INTERSECTION POINTS, PART OF LSP RITA ADAPTA
 ;PART THIS IS PART OF THE LISP OF RITA FOR DRAWING THE INTERSECTION POINTS AND THE CENTER OF THE CURVE,
 ;IF IT IS POSSIBLE TO REPROGRAM, IT HAS AS A REDUCTION TO 25% OF ITS SIZE,
 ;HAVING AS DEFERENCIA THE INTERSECTION POINT AND THE CENTER OF THE CURVE
  (defun grdraw-id_arc ( / )
 (command "._line" pt_start pt_vtx "")
 (command "._line" pt_vtx pt_end "")
 (command "._line" pt_start pt_cen "")
 (command "._line" pt_cen pt_end "")
    ;(grdraw (trans pt_start 0 1) (trans pt_vtx 0 1) 1)
    ;(grdraw (trans pt_vtx 0 1) (trans pt_end 0 1) 1)
    ;(grdraw (trans pt_start 0 1) (trans pt_cen 0 1) 3)
    ;(grdraw (trans pt_cen 0 1) (trans pt_end 0 1) 3)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;CONTINUATION OF LISP ROAD
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        spc (if (= 1 (getvar 'cvport))
                (vla-get-paperspace c_doc)
                (vla-get-modelspace c_doc)
            );end_if
        sv_lst (list 'osmode 'cmdecho'textstyle 'TEXTSIZE 'clayer);;system variable names list
    sv_vals (mapcar 'getvar sv_lst);;get current values
  );end_setq
  (cond ( (null (tblsearch "LAYER" "TGCOTA")) (vlax-put (vla-add (vla-get-layers c_doc) "TGCOTA") 'color 7)))
  (cond ( (null (tblsearch "STYLE" "DIM"))
          (setq nw_style (vla-add (vla-get-textstyles c_doc) "TGCOTA")
                nw_font (strcat (getenv "systemroot") "\\Fonts\\ARIAL.ttf")
          );end_setq
          (mapcar '(lambda (pr val) (vlax-put-property nw_style pr val))
            (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
            (list nw_font 0.0 (/ (* 0.0 pi) 180) 1.0 0.0)
          );end_mapcar
        )
  );end_cond
  (initget 6)
   ;;;;;;;;;;;;;;NEED A VARIABLE TO CONTROL THE TEXT "SPEED OF PROJECT" IS .....
  ;EX:  (setq SPEED (getreal (strcat "\n SPECIFY SPEED OF PROJECT <" ( 40km/h?) "> : ")))
  (setq HTX (getreal (strcat "\n ADD/SPECIFY TEXT HEIGHT <" (rtos (getvar "TEXTSIZE")) "> : ")))
  (if (not HTX) (setq HTX (getvar 'TEXTSIZE)))
  (mapcar 'setvar sv_lst (list 0 0 "TGCOTA" HTX "TGCOTA")); give them the values you want
  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (vla-startundomark c_doc)
  (prompt "\nSelect polylines : ")
  (while (null (setq ss (ssget '((0 . "LWPOLYLINE")))))
    (princ "\nSelection is Empty. Selected Items were not LWPolylines!")
  );end_while
  
  (vlax-for obj (vla-get-activeselectionset c_doc)
    (setq pr -1.0)
    (repeat (fix (vlax-curve-getendparam obj))
      (setq pr (1+ pr)
            pt_start (vlax-curve-getpointatparam obj pr)
            pt_end (vlax-curve-getpointatparam obj (1+ pr))
            seg_len (- (vlax-curve-getdistatparam obj (1+ pr)) (vlax-curve-getdistatpoint obj pt_start))
            seg_bulge (vla-getbulge obj pr)
            rad (if (zerop seg_bulge) 0.0 (abs (/ seg_len (* 4.0 (atan seg_bulge)))))
            alpha (if (zerop seg_bulge) (angle (trans pt_start 0 1) (trans pt_end 0 1)) 0.0)
            m_pt (vlax-curve-getpointatparam obj (+ 0.5 pr))
            alpha (angle '(0 0 0) (vlax-curve-getfirstderiv obj (+ 0.5 pr)))
            t_ang alpha
  ;;;;;;;;;;;;;;ADD VARIÁVEL CURVE N+1
  ;;;;;;;;;;;;;;ADD VARIÁVEL VERTEX N+1, FOR POINT INTERSECTION
      );end_setq
      (if (< (/ pi 2) t_ang (* (/ pi 2) 3)) (setq t_ang (+ t_ang pi)))
      (if (= seg_bulge 0.0)
 
 ;;;;;;;;;;;;;;ADD VARIÁVEL CURVE N+1
        (setq t_str (strcat "DISTANCE: " (rtos seg_len 2 3) "m\\P Az:" (vl-string-subst "%%d" "d" (angtos alpha 1 4))))
  
 ;;;;;;;;;;;;;;WHEN SUPPLEMENTING WITH YOUR LISP DATA IN THIS ERROR ITEM FOR LACK OF VARABLE
        ;;;;;;;;;;;;;;AT THE POINTS WHERE THE ARCS ARE THE TEXT BOX INVADES THE DESIGN AREA, AND LINE SPACE FACTOR OF 0.80
 (setq t_str (strcat "CURVE N+1  "  "m\\P AC:" (angtos (- pi (* 2 alpha)) 0 4) "%%d" "d" "m\\P TG:" (rtos (distance pt_start pt_vtx) 2 3) "m\\P RAY:" (rtos rad 2 3) "m\\P DISTANCE:" (rtos seg_len 2 3)"m."))
 ;;;;;;;;;;;;;;TEXT FOR VERTEX N+1, FOR POINT INTERSECTION
 ;(setq t_str (strcat "Vertex" N+1));;;;;;;;;ONLY PI
 ;;;;;;;;;;;;;;TEXT FOR VERTEX N+1, FOR POINT INTERSECTION
 ;(setq t_str (strcat "Vertex" N+1));;;;;;;;;ONLY PI
 
      );end_if
      (setq nw_obj (vla-addmtext spc (vlax-3d-point m_pt) 0.0 t_str))
      (vla-getboundingbox nw_obj 'll 'ur)
      (setq ll (vlax-safearray->list ll)
            ur (vlax-safearray->list ur)     
            t_width (+ (* (distance ll ur) (cos (angle ll ur))) 5.0)
      );end_setq
      (if (>= t_width seg_len)
        (setq att_pt 5
              t_width seg_len
        );end_setq
        (setq att_pt 8 
    
   ;;;;;;;;;;;;;;NEED A VARIABLE TO CONTROL THE SPACING OF THE TEXT AND AXIS POLYLINE (-10)
    ;;;;;;;;;;;;;;EX:  (setq DIST_TXT (getreal (strcat "\nADD/Specify distance TEXTSIZE/polyline<" ( 10m?) "> : ")))
              m_pt (polar m_pt (+ t_ang (/ pi 2)) (* (getvar 'TEXTSIZE) -10.0))
        );end_setq
      );end_if       
      (mapcar '(lambda (pr val) (vlax-put nw_obj pr val))
        (list 'AttachmentPoint 'Insertionpoint 'Height 'DrawingDirection 'Rotation 'Width)
        (list att_pt m_pt (getvar 'TEXTSIZE) 5 t_ang 0.0)
      );end_mapcar
    );end_repeat
  );end_for
;  (mapcar 'setvar sv_lst sv_vals)
 (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (princ)
);end_defun
4865 KB
0 Likes
Like
Report
Message 4 of 12

CADaSchtroumpf
Advisor
Advisor
in reply to rolisonfelipe
‎02-13-2019 01:13 AM

Hi,

You use:

(setq t_str (strcat "CURVE N+1  "  "m\\P AC:" (angtos (- pi (* 2 alpha)) 0 4) "%%d" "d" "m\\P TG:" (rtos (distance pt_start pt_vtx) 2 3) "m\\P RAY:" (rtos rad 2 3) "m\\P DISTANCE:" (rtos seg_len 2 3)"m."))

but you don't have calculate pt_vtx ...

 

change

(setq pr (1+ pr)
            pt_start (vlax-curve-getpointatparam obj pr)
            pt_end (vlax-curve-getpointatparam obj (1+ pr))
            seg_len (- (vlax-curve-getdistatparam obj (1+ pr)) (vlax-curve-getdistatpoint obj pt_start))
            seg_bulge (vla-getbulge obj pr)
            rad (if (zerop seg_bulge) 0.0 (abs (/ seg_len (* 4.0 (atan seg_bulge)))))
            alpha (if (zerop seg_bulge) (angle (trans pt_start 0 1) (trans pt_end 0 1)) 0.0)
            m_pt (vlax-curve-getpointatparam obj (+ 0.5 pr))
            alpha (angle '(0 0 0) (vlax-curve-getfirstderiv obj (+ 0.5 pr)))
            t_ang alpha
  ;;;;;;;;;;;;;;ADD VARIÁVEL CURVE N+1
  ;;;;;;;;;;;;;;ADD VARIÁVEL VERTEX N+1, FOR POINT INTERSECTION
      )

by

(setq pr (1+ pr)
            pt_start (vlax-curve-getpointatparam obj pr)
            pt_end (vlax-curve-getpointatparam obj (1+ pr))
            seg_len (- (vlax-curve-getdistatparam obj (1+ pr)) (vlax-curve-getdistatpoint obj pt_start))
            seg_bulge (vla-getbulge obj pr)
            rad (if (zerop seg_bulge) 0.0 (abs (/ seg_len (* 4.0 (atan seg_bulge)))))
            alpha (if (zerop seg_bulge) (angle (trans pt_start 0 1) (trans pt_end 0 1)) 0.0)
            pt_vtx (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
            m_pt (vlax-curve-getpointatparam obj (+ 0.5 pr))
            alpha (angle '(0 0 0) (vlax-curve-getfirstderiv obj (+ 0.5 pr)))
            t_ang alpha
  ;;;;;;;;;;;;;;ADD VARIÁVEL CURVE N+1
  ;;;;;;;;;;;;;;ADD VARIÁVEL VERTEX N+1, FOR POINT INTERSECTION
      )
0 Likes
Like
Report
Message 5 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-13-2019 02:14 AM

(setq t_str (strcat "CURVE N+1  "  "m\\P AC:" (angtos (- pi (* 2 alpha)) 0 4) "%%d" "d" "m\\P TG:" (rtos (distance pt_start pt_vtx) 2 3) "m\\P RAY:" (rtos rad 2 3) "m\\P DISTANCE:" (rtos seg_len 2 3)"m."))

 

TAKE A ERROR THIS LINHA: Oops an Error : bad argument type: 2D/3D point: nil occurred.

 

(vl-load-com)
(DEFUN C:TG () (C:ROAD))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ROAD ( / *error* c_doc spc sv_lst sv_vals nw_style nw_font htx ss o_type pr pt_start pt_end seg_len seg_bulge rad alpha m_pt t_ang t_str nw_obj ll ur att_pt t_width)
                          
 (defun *error* ( msg )
  (mapcar 'setvar sv_lst sv_vals)
  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
  (princ)
 );end_*error*_defun
 
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        spc (if (= 1 (getvar 'cvport))
                (vla-get-paperspace c_doc)
                (vla-get-modelspace c_doc)
            );end_if
    ;sv_lst (list 'osmode 'cmdecho )
        sv_lst (list 'osmode 'cmdecho'textstyle 'textsize 'clayer);;system variable names list
    sv_vals (mapcar 'getvar sv_lst);;get current values
  );end_setq
  (cond ( (null (tblsearch "LAYER" "DIMENSIONS")) (vlax-put (vla-add (vla-get-layers c_doc) "DIMENSIONS") 'color 7)))
  (cond ( (null (tblsearch "STYLE" "DIM"))
          (setq nw_style (vla-add (vla-get-textstyles c_doc) "ELEV_ARIAL_1")
                nw_font (strcat (getenv "systemroot") "\\Fonts\\Arial.ttf")
          );end_setq
          (mapcar '(lambda (pr val) (vlax-put-property nw_style pr val))
            (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
            (list nw_font 0.0 (/ (* 0.0 pi) 180) 1.0 0.0)
          );end_mapcar
        )
  );end_cond
  ;(mapcar 'setvar sv_lst (list 0 0 1 90.0))
  (initget 6)
  (setq htx (getreal (strcat "\nSpecify text height <" (rtos (getvar "TEXTSIZE")) "> : ")))
  (if (not htx) (setq htx (getvar 'textsize)))
  (mapcar 'setvar sv_lst (list 0 0 "ELEV_ARIAL_1" htx "DIMENSIONS")); give them the values you want
 (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
 (vla-startundomark c_doc)
  (prompt "\nSelect polylines : ")
  (while (null (setq ss (ssget '((0 . "LWPOLYLINE")))))
    (princ "\nSelection is Empty. Selected Items were not LWPolylines!")
  );end_while
  
  (vlax-for obj (vla-get-activeselectionset c_doc)
    (setq pr -1.0)
    (repeat (fix (vlax-curve-getendparam obj))
      (setq pr (1+ pr)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;Maybe it's not for Ausenci that part

        (setq typ_obj (vla-get-ObjectName obj))
        (if (eq typ_obj "AcDbArc")
          (progn
            (setq
              pt_start (vlax-get obj 'StartPoint)
              pt_end (vlax-get obj 'EndPoint)
              pt_cen (vlax-get obj 'Center)
              rad (vlax-get obj 'Radius)
              alpha (* (vlax-get obj 'TotalAngle) 0.5)
              seg_len (vlax-get obj 'ArcLength)
              pt_vtx (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))
              nb (1+ nb)
            )
            (grdraw-id_arc)
            (add_mt_arc)
          )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
            pt_start (vlax-curve-getpointatparam obj pr)
            ;pt_end (vlax-curve-getpointatparam obj (1+ pr))
            seg_len (- (vlax-curve-getdistatparam obj (1+ pr)) (vlax-curve-getdistatpoint obj pt_start))
            seg_bulge (vla-getbulge obj pr)
            ;rad (if (zerop seg_bulge) 0.0 (abs (/ seg_len (* 4.0 (atan seg_bulge)))))
            ;alpha (if (zerop seg_bulge) (angle (trans pt_start 0 1) (trans pt_end 0 1)) 0.0)
            m_pt (vlax-curve-getpointatparam obj (+ 0.5 pr))
            alpha (angle '(0 0 0) (vlax-curve-getfirstderiv obj (+ 0.5 pr)))
            t_ang alpha
      );end_setq
      (if (< (/ pi 2) t_ang (* (/ pi 2) 3)) (setq t_ang (+ t_ang pi)))
      (if (= seg_bulge 0.0)
        (setq t_str (strcat "DISTANCE: " (rtos seg_len 2 3) "m\\P Az:" (vl-string-subst "%%d" "d" (angtos alpha 1 4))))
        (setq t_str (strcat "CURVE N+1  "  "m\\P AC:" (angtos (- pi (* 2 alpha)) 0 4) "%%d" "d" "m\\P TG:" (rtos (distance pt_start pt_vtx) 2 3) "m\\P RAY:" (rtos rad 2 3) "m\\P DISTANCE:" (rtos seg_len 2 3)"m."))
      );end_if
      (setq nw_obj (vla-addmtext spc (vlax-3d-point m_pt) 0.0 t_str))
      (vla-getboundingbox nw_obj 'll 'ur)
      (setq ll (vlax-safearray->list ll)
            ur (vlax-safearray->list ur)     
            t_width (+ (* (distance ll ur) (cos (angle ll ur))) 5.0)
      );end_setq
      (if (>= t_width seg_len)
        (setq att_pt 5
              t_width seg_len
        );end_setq
        (setq att_pt 8
              m_pt (polar m_pt (+ t_ang (/ pi 2)) (* (getvar 'textsize) 0.5))
        );end_setq
      );end_if      
      (mapcar '(lambda (pr val) (vlax-put nw_obj pr val))
        ;(list 'AttachmentPoint 'Insertionpoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'Width)
        ;(list att_pt m_pt (getvar 'textsize) 5 "ELEV_ARIAL_1" "DIMENSIONS" t_ang t_width)
        (list 'AttachmentPoint 'Insertionpoint 'Height 'DrawingDirection 'Rotation 'Width)
        (list att_pt m_pt (getvar 'textsize) 5 t_ang 0.0)
      );end_mapcar
    );end_repeat
  );end_for
(mapcar 'setvar sv_lst sv_vals)
 (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (princ)
);end_defun

0 Likes
Like
Report
Message 6 of 12

CADaSchtroumpf
Advisor
Advisor
in reply to rolisonfelipe
‎02-13-2019 07:35 AM

With my source code. Try it!

 

(vl-load-com)
(defun c:ROAD ( / js n AcDoc Space ename obj pr nb typ_obj oldim oldlay a_base a_dir
 pt_start pt_end pt_cen rad alpha pt_vtx dist_start dist_end seg_len seg_bulge)
  (defun add_mt_arc (ins_txt value_str a / nw_obj)
    (setq nw_obj
      (vla-addMtext Space
        (vlax-3d-point (trans ins_txt 1 0))
        0.0
        value_str
      )
    )
    (mapcar
      '(lambda (pr val)
        (vlax-put nw_obj pr val)
      )
      (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
      (list 5 (getvar "TEXTSIZE") 5 ins_txt "ELEV_ARIAL_1" "DIMENSIONS" (if (and (< a (* pi 0.5)) (> a (* pi 1.5))) (setq a (+ a pi))))
    )
    (entmod
      (append
      (vl-remove-if
        (function
          (lambda (x)
            (or (member (car x) '(90 63 421 45))
              (< 419 (car x) 440)
            )
          )
        )
        (entget (entlast))
      )
      (list
        '(90 . 1)
        '(63 . 41)
        '(421 . 16770196)
        '(45 . 1.5)
      )
      )
    )
    (entupd (entlast))
  )
  (princ "\nSelect polylines/Arc : ")
  (setq
    js
    (ssget
      '((-4 . "<OR")
        (-4 . "<AND")
          (0 . "POLYLINE")
          (-4 . "<NOT")
            (-4 . "&") (70 . 126)
          (-4 . "NOT>")
        (-4 . "AND>")
        (0 . "LWPOLYLINE,ARC")
        (-4 . "OR>"))
    )
    n -1
  )
  (cond
    (js
      (setq
        AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
        Space
          (if (= 1 (getvar "CVPORT"))
            (vla-get-PaperSpace AcDoc)
            (vla-get-ModelSpace AcDoc)
          )
        nb 0
      )
      (cond
        ((null (tblsearch "LAYER" "DIMENSIONS"))
          (vlax-put (vla-add (vla-get-layers AcDoc) "DIMENSIONS") 'Color 7)
        )
      )
      (cond
        ((null (tblsearch "STYLE" "ELEV_ARIAL_1"))
          (setq
            nw_style (vla-add (vla-get-textstyles AcDoc) "ELEV_ARIAL_1")
            nw_font (strcat (getenv "systemroot") "\\Fonts\\Arial.ttf")
          )
          (mapcar '(lambda (pr val) (vlax-put-property nw_style pr val))
            (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
            (list nw_font 0.0 (/ (* 0.0 pi) 180) 1.0 0.0)
          )
        )
      )
      (setq
        oldim (getvar "dimzin")
        oldlay (getvar "clayer")
        a_base (getvar "ANGBASE")
        a_dir (getvar "ANGDIR")
      )
      (setvar "dimzin" 0) (setvar "clayer" "DIMENSIONS")
      (setvar "ANGBASE" 0) (setvar "ANGDIR" 0)
      (initget 6)
      (setq h_t (getdist (getvar "VIEWCTR") (strcat "\nTaille du texte <" (rtos (getvar "textsize")) ">: ")))
      (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))
      (repeat (sslength js)
        (setq
          ename (ssname js (setq n (1+ n)))
          obj (vlax-ename->vla-object ename)
          pr -1
          nb 0
        )
        (setq typ_obj (vla-get-ObjectName obj))
        (if (eq typ_obj "AcDbArc")
          (progn
            (setq
              pt_start (vlax-get obj 'StartPoint)
              pt_end (vlax-get obj 'EndPoint)
              pt_cen (vlax-get obj 'Center)
              rad (vlax-get obj 'Radius)
              alpha (* (vlax-get obj 'TotalAngle) 0.5)
              seg_len (vlax-get obj 'ArcLength)
              pt_vtx (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))
              nb (1+ nb)
            )
            (add_mt_arc
              (mapcar '* (mapcar '+ pt_start pt_end) '(0.5 0.5 0.5))
              (strcat
                "{\\fArial Narrow|b0|i0|c0|p34;"
                "CURVE N+"
                (itoa nb)
                "\\P AC:"
                (angtos (- pi (* 2 alpha)) 0 4)
                "%%ddm\\P TG:"
                (rtos (distance pt_start pt_vtx) 2 3)
                "m\\P RAY:"
                (rtos rad 2 3)
                "m\\P DISTANCE:"
                (rtos seg_len 2 3)
                "m"
                "}"
              )
              (angle pt_start pt_end)
            )
          )
          (repeat (fix (vlax-curve-getEndParam obj))
            (setq
              dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))
              dist_end (vlax-curve-GetDistAtParam obj (1+ pr))
              pt_start   (vlax-curve-GetPointAtParam obj pr)
              pt_end (vlax-curve-GetPointAtParam obj (1+ pr))
              seg_len (- dist_end dist_start)
              seg_bulge (vla-GetBulge obj pr)
            )
            (if (not (zerop seg_bulge))
              (progn
                (setq
                  rad (/ seg_len (* 4.0 (atan seg_bulge)))
                  alpha (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))
                  pt_cen (polar pt_start alpha rad)
                  pt_vtx (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
                  alpha (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))
                  nb (1+ nb)
                )
                (add_mt_arc
                  (vlax-curve-GetPointAtParam obj (+ 0.5 pr))
                  (strcat
                    "{\\fArial Narrow|b0|i0|c0|p34;"
                    "CURVE N+"
                    (itoa nb)
                    "\\P AC:"
                    (angtos (- pi (* 2 alpha)) 0 4)
                    "%%ddm\\P TG:"
                    (rtos (distance pt_start pt_vtx) 2 3)
                    "m\\P RAY:"
                    (rtos rad 2 3)
                    "m\\P DISTANCE:"
                    (rtos seg_len 2 3)
                    "m"
                    "}"
                  )
                  (angle pt_start pt_end)
                )
              )
              (add_mt_arc
                (vlax-curve-GetPointAtParam obj (+ 0.5 pr))
                (strcat
                  "{\\fArial Narrow|b0|i0|c0|p34;"
                  "DISTANCE "
                  (itoa (setq nb (1+ nb)))
                  ": "
                  (rtos seg_len 2 3)
                  "m\\P Az:"
                  (vl-string-subst "%%d" "d" (angtos (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge)))) 1 4))
                  "}"
                )
                (angle pt_start pt_end)
              )
            )
          )
        )
      )
      (setvar "dimzin" oldim) (setvar "clayer" oldlay)
      (setvar "ANGBASE" a_base) (setvar "ANGDIR" a_dir)
    )
  )
  (prin1)
)
0 Likes
Like
Report
Message 7 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-13-2019 10:02 PM
HI !@CADaSchtroumpf I TESTED YOUR LSP AND GAVE ERROR
Command: (LOAD "C:/Users/rolis/OneDrive/Área de Trabalho/TG ROAD - Copia - Copia.lsp") C:ROAD
Command: TG
Select polylines/Arc :
Select objects: 1 found
Select objects:
Taille du texte <59.9340>:
ERRO : Parâmetro não opcional
Cannot invoke (command) from *error* without prior call to (*push-error-using-command*).
Converting (command) calls to (command-s) is recommended.
, AND NEED CLICKING ON SITE TO INSERT TEXT,
I TRIED TO IMPROVE WITH MY MOUNT, TO ADD THE TEXT TO THE SIZE I HAVE SELECTED, BUT IS ERRORING THE LIST
The Lisp loaded down this clean wheel 100%, but still does not have all the calculation parings, but ADD the texts altomatically
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(vl-load-com)
(DEFUN C:TG () (C:ROAD))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ROAD ( / *error* c_doc spc sv_lst sv_vals nw_style nw_font htx ss o_type pr
   pt_start pt_end seg_len seg_bulge rad alpha m_pt t_ang t_str nw_obj
  ll ur att_pt t_width)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                    
 (defun *error* ( msg )
  (mapcar 'setvar sv_lst sv_vals)
  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
  (princ)
 );end_*error*_defun

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        spc (if (= 1 (getvar 'cvport))
                (vla-get-paperspace c_doc)
                (vla-get-modelspace c_doc)
            );end_if
          sv_lst (list 'osmode 'cmdecho 'textstyle 'TEXTSIZE);;system variable names list
   sv_vals (mapcar 'getvar sv_lst);;get current values
  );end_setq
  (cond ( (null (tblsearch "LAYER" "TGCOTA")) (vlax-put (vla-add (vla-get-layers c_doc) "TGCOTA") 'color 7)))
  (cond ( (null (tblsearch "STYLE" "DIM"))
          (setq nw_style (vla-add (vla-get-textstyles c_doc) "DIM")
                nw_font (strcat (getenv "systemroot") "\\Fonts\\Arial.ttf")
          );end_setq
          (mapcar '(lambda (pr val) (vlax-put-property nw_style pr val))
            (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
            (list nw_font 0.0 (/ (* 0.0 pi) 180) 1.0 0.0)
          );end_mapcar
        )
  );end_cond
;  (mapcar 'setvar sv_lst (list 0 0 1 90.0))
  (initget 6)
  (setq htx (getreal (strcat "\nSpecify text height <" (rtos (getvar "TEXTSIZE")) "> : ")))
  (if (not htx) (setq htx (getvar 'TEXTSIZE)))
  (mapcar 'setvar sv_lst (list 0 0 "DIM" htx)); give them the values you want
 (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
 (vla-startundomark c_doc)
  (prompt "\nSelect polylines : ")
  (while (null (setq ss (ssget '((0 . "LWPOLYLINE")))))
    (princ "\nSelection is Empty. Selected Items were not LWPolylines!")
  );end_while
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; IMPROVISATION
        (setq typ_obj (vla-get-ObjectName obj))
        (if (eq typ_obj "AcDbArc")
          (progn
            (setq
              pt_start (vlax-get obj 'StartPoint)
              pt_end (vlax-get obj 'EndPoint)
              pt_cen (vlax-get obj 'Center)
              rad (vlax-get obj 'Radius)
              alpha (* (vlax-get obj 'TotalAngle) 0.5)
              seg_len (vlax-get obj 'ArcLength)
              pt_vtx (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))
              nb (1+ nb)
            )
                 (sublisp01_draw_lines_in_arc)
                 (sublisp02_CHANGENT)
                 (sublisp03_draw_CHMARKS)
          )
          (repeat (fix (vlax-curve-getEndParam obj))
            (setq
              dist_start (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))
              dist_end (vlax-curve-GetDistAtParam obj (1+ pr))
              pt_start   (vlax-curve-GetPointAtParam obj pr)
              pt_end (vlax-curve-GetPointAtParam obj (1+ pr))
              seg_len (- dist_end dist_start)
              seg_bulge (vla-GetBulge obj pr)
            )
            (if (not (zerop seg_bulge))
              (progn
                (setq
                  rad (/ seg_len (* 4.0 (atan seg_bulge)))
                  alpha (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))
                  pt_cen (polar pt_start alpha rad)
                  pt_vtx (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
                  alpha (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))
                  nb (1+ nb)
                )
                 (sublisp01_draw_lines_in_arc)
                 (sublisp02_CHANGENT)
                 (sublisp03_draw_CHMARKS)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; IMPROVISATION
      (if (< (/ pi 2) t_ang (* (/ pi 2) 3)) (setq t_ang (+ t_ang pi)))
      (if (= seg_bulge 0.0)
 (setq t_str (strcat "Az:" (vl-string-subst "%%d" "d" (angtos alpha 1 4)) "\\P DISTANCE:" (rtos seg_len 2 3) "m" ))
        (setq t_str (strcat "CURVE ?" "m\\P AC:" (angtos (- pi (* 2 alpha)) 0 4) "%%d" "d" "m\\P TG: ?" "m\\P RAY:" (rtos rad 2 3) "m\\P DISTANCE:" (rtos seg_len 2 3)"m."))
       );end_if
      (setq nw_obj (vla-addmtext spc (vlax-3d-point m_pt) 0.0 t_str))
      (vla-getboundingbox nw_obj 'll 'ur)
      (setq ll (vlax-safearray->list ll)
            ur (vlax-safearray->list ur)     
            t_width (+ (* (distance ll ur) (cos (angle ll ur))) 5.0)
      );end_setq
      (if (>= t_width seg_len)
        (setq att_pt 5
              t_width seg_len
        );end_setq
        (setq att_pt 8
              m_pt (polar m_pt (+ t_ang (/ pi 2)) (* (getvar 'TEXTSIZE) 0.5))
        );end_setq
      );end_if       
      (mapcar '(lambda (pr val) (vlax-put nw_obj pr val))
        ;(list 'AttachmentPoint 'Insertionpoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'Width)
        ;(list att_pt m_pt (getvar 'TEXTSIZE) 5 "DIM" "TGCOTA" t_ang t_width)
        (list 'AttachmentPoint 'Insertionpoint 'Height 'DrawingDirection 'Rotation 'Width)
        (list att_pt m_pt (getvar 'TEXTSIZE) 5 t_ang 0.0)
      );end_mapcar
    );end_repeat
  );end_for
  (mapcar 'setvar sv_lst sv_vals)
 (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (princ)
);end_defun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUBLISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(setq chainage_pi            3.1415926535897932384626433832795
      chainage_halfpi        1.5707963267948966192313216916398
      chainage_twopi         6.2831853071795864769252867665590
      chainage_oneandahalfpi 4.7123889803846898576939650749193)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUBLISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 (defun C: sublisp01_draw_lines_in_arc ( / )
    (command "._line" pt_start pt_vtx "")
     (command "._line" pt_vtx pt_end "")
     (command "._line" pt_start pt_cen "")
     (command "._line" pt_cen pt_end "")
   )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUBLISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; CHANGENT - Draw tangent marks where segments join (but not at start or end of polyline)
(defun sublisp02_CHANGENT ( / SOURCEpolyline COUNThrough TANGENTmark i1 ANGLEand ANGLE_start POINTangent)
 (if (/= (setq SOURCEpolyline (chainage_selectpline)) nil)
  (progn
   (setq COUNThrough 0 TANGENTmark (* (getvar "TEXTSIZE") 0.75))
   (repeat (length SOURCEpolyline)
    (setq i1 (nth COUNThrough SOURCEpolyline))
    (if (> COUNThrough 0)
     (progn
      (if (= (car i1) "LINE")
       (setq ANGLE_start (+ (angle (nth 1 i1) (nth 2 i1)) chainage_halfpi))
       (progn
        (setq ANGLE_start (nth 6 i1))
        (if (< ANGLE_start (nth 7 i1))
         (setq ANGLE_start (+ ANGLE_start chainage_pi))
        )
       )
      )
      (setq ANGLEand (/ (+ ANGLEand ANGLE_start) 2.0) POINTangent (nth 1 i1))
      (entmake (list (cons 0 "LINE") (cons 100 "AcDbEntity") (cons 100 "AcDbLine")
                     (append (list 10) (polar POINTangent ANGLEand TANGENTmark))
                     (append (list 11) (polar POINTangent (+ ANGLEand chainage_pi) (* TANGENTmark 60)))))
      (entmake (list (cons 0 "CIRCLE") (cons 100 "AcDbEntity") (cons 100 "AcDbCircle")
                     (append (list 10) (polar POINTangent ANGLEand (* TANGENTmark 1.35)))
                     (cons 40 (* TANGENTmark 0.35))))
      (entmake (list (cons 0 "CIRCLE") (cons 100 "AcDbEntity") (cons 100 "AcDbCircle")
                     (append (list 10) (polar POINTangent (+ ANGLEand chainage_pi) (* TANGENTmark 1.35)))
                     (cons 40 (* TANGENTmark 0.35))))
     )
    )
    (if (= (car i1) "LINE")
     (setq ANGLEand (+ (angle (nth 1 i1) (nth 2 i1)) chainage_halfpi))
     (progn
      (setq ANGLEand (nth 7 i1))
      (if (< (nth 6 i1) ANGLEand)
       (setq ANGLEand (+ ANGLEand chainage_pi))
      )
     )
    )
    (setq COUNThrough (1+ COUNThrough))
   )
   (princ "\nCommand finished")
  )
 )
 (chainage_atend)
 (princ)
)
; SOURCEpolyline = source polyline parsed list
; COUNThrough = count through list SOURCEpolyline
; TANGENTmark = size of tangent mark
; i1 = item in list SOURCEpolyline
; ANGLEand = angle at end of segment
; ANGLE_start = angle at start of next segment
; POINTangent = position of tangent mark on polyline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;SUBLISP
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:sublisp03_draw_CHMARKS (/ SOURCEpolyline CHAINAGEmark CHAINAGEmarklength REGULARinterval CHAINAGEstyle CHAINAGEinitial CHAINAGEend)
 (chainage_atstart)
 (if (/= (setq SOURCEpolyline (chainage_selectpline)) nil)
  (progn
   (setq CHAINAGEmark (chainage_getglobalvalue "\nEnter chainage value at start of polyline"
             chainage_chatstart 0.0 nil))
   (setq chainage_chatstart CHAINAGEmark)
   (setq CHAINAGEmarklength (getvar "TEXTSIZE"))
   (setq REGULARinterval (chainage_getglobalvalue "\nEnter interval between chainage marks (min. interval of 1.0)"
             chainage_reginterval 10.0 nil))
   (if (< REGULARinterval 1.0)
    (setq REGULARinterval 1.0)
   )
   (setq chainage_reginterval REGULARinterval)
   (setq CHAINAGEstyle (chainage_getglobalvalue "\nEnter chainage mark style (1=n.nnn 2=n+nn 3=n+nn.nn)"
             chainage_markstyle 1 T))
   (if (or (< CHAINAGEstyle 1) (> CHAINAGEstyle 3))
    (setq CHAINAGEstyle 1)
   )
   (setq chainage_markstyle CHAINAGEstyle)
   (setq CHAINAGEinitial (- CHAINAGEmark (rem CHAINAGEmark REGULARinterval)))
   (if (< CHAINAGEinitial CHAINAGEmark)
    (setq CHAINAGEinitial (+ CHAINAGEinitial REGULARinterval))
   )
   (setq CHAINAGEend (+ CHAINAGEmark (parse_polyline_getlen SOURCEpolyline)))
   (while (<= CHAINAGEinitial CHAINAGEend)
    (chmark_draw SOURCEpolyline CHAINAGEmark CHAINAGEinitial CHAINAGEstyle CHAINAGEmarklength)
    (setq CHAINAGEinitial (+ CHAINAGEinitial REGULARinterval))
   )
   (princ "\nCommand finished")
  )
 )
 (chainage_atend)
 (princ)
)
; Draw chainage marks (e.g. "100.000 -") at regular intervals along source polyline
; Global Variables:
; =================
; chainage_chatstart = chainage value at start of polyline
; chainage_reginterval = regular interval between chainage marks
; chainage_markstyle = how to display chainage 1 = n.nnn 2 = n+nn 3 = n+nn.nn
; Internal Variables:
; ===================
; SOURCEpolyline = source polyline parsed list
; CHAINAGEmark = chainage value at start of polyline
; CHAINAGEmarklength = chainage mark line length
; REGULARinterval = regular interval between chainage marks
; CHAINAGEstyle = chainage mark number style
; CHAINAGEinitial = chainage of initial and then current chainage mark
; CHAINAGEend = chainage at end of polyline
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
TG ROAD.lsp
0 Likes
Like
Report
Message 8 of 12

CADaSchtroumpf
Advisor
Advisor
in reply to rolisonfelipe
‎02-14-2019 01:00 AM
@rolisonfelipe  a écrit :
HI !@CADaSchtroumpf I TESTED YOUR LSP AND GAVE ERROR

ERRO : Parâmetro não opcional
 

Sorry for my error,

replace fonction add_mt_arc by this in my code.

  (defun add_mt_arc (ins_txt value_str a / nw_obj)
    (setq nw_obj
      (vla-addMtext Space
        (vlax-3d-point (trans ins_txt 1 0))
        0.0
        value_str
      )
    )
    (mapcar
      '(lambda (pr val)
        (vlax-put nw_obj pr val)
      )
      (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
      (list 5 (getvar "TEXTSIZE") 5 ins_txt "ELEV_ARIAL_1" "DIMENSIONS" (if (and (< a (* pi 0.5)) (> a (* pi 1.5))) (setq a (+ a pi)) a))
    )
    (entmod
      (append
      (vl-remove-if
        (function
          (lambda (x)
            (or (member (car x) '(90 63 421 45))
              (< 419 (car x) 440)
            )
          )
        )
        (entget (entlast))
      )
      (list
        '(90 . 1)
        '(63 . 41)
        '(421 . 16770196)
        '(45 . 1.5)
      )
      )
    )
    (entupd (entlast))
  )
0 Likes
Like
Report
Message 9 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-14-2019 01:41 AM

@CADaSchtroumpf 

fr, Ne pas avoir à s'excuser pour quoi que ce soit, parce que c'était Fantastico, a travaillé sa chronogramation, je m'excuse de Pala haute boîte, mais je l'ai fait pour différencier l'information, depuis mes compliments.

 

Ing, Do not have to apologize for anything, because it is fantastic, worked its programming, I apologize Pala high box, but I did it to differentiate the information, since my compliments

0 Likes
Like
Report
Message 10 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-14-2019 04:29 AM

I made an adjustment in the radius of the curve that's giving negative

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

               ray    (if (zerop seg_bulge) 0.0 (abs (/ seg_len (* 4.0 (atan seg_bulge)))))

 (add_mt_arc
                  (vlax-curve-GetPointAtParam obj (+ 0.5 pr))
                  (strcat
                    "{\\fARIAL|b0|i0|c0|p34;"
                    "CURVE "   (itoa nb)
                    "\\P AC:"   (angtos (- pi (* 2 alpha)) 0 4)
                    "%%ddm\\P TG:"  (rtos (distance pt_start pt_vtx) 2 3)
                    "m\\P RAY:"  (rtos ray 2 3)
                    "m\\P DISTANCE:"  (rtos seg_len 2 3) "m" "}" )
                  (angle pt_start pt_end)))

 
the azimuth is summing + 90 º, I tried to rewrite with the function so 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
"Az: " (VL-string-subst  "%% d "  "D " (Angtos Alpha 1 4))
 
and with this modification of the error, has a proposal
 
And one last remark, in this function the text accompanies the axis of the road, and in the previous Lisp I found the location of add a spacing relative to the axis, with this modification where it could add this displacement
0 Likes
Like
Report
Message 11 of 12

CADaSchtroumpf
Advisor
Advisor
in reply to rolisonfelipe
‎02-14-2019 06:51 AM

negative radius if whent arc turn in positive clock or positive otherwise.

But you can write simply the value positive of radius

replace: "m\\P RAY:" (rtos rad 2 3)

by: "m\\P RAY:" (rtos (abs rad) 2 3)

 

For Az:

You can force your angular system in the code see for exemple: (setvar "ANGBASE" (* 0.5 pi)) (setvar "ANGDIR" 1)

 

Controle your formule for calulate the angle desired (I have copied your formula in code proposed, no verified)

And see (angtos) for good notation.

0 Likes
Like
Report
Message 12 of 12

rolisonfelipe
Collaborator
Collaborator
in reply to CADaSchtroumpf
‎02-15-2019 10:29 PM
Hello, Good morning!
Have as re-add, this fragment, because I discovered that it is possible to shift the text from the project axis up or down, but when add that fragment, and add the variables give error in executing in the CAD.
If possible add a variable to perform this offset, it would be perfect.
ex:(setq OFFSET (getdist (getvar "VIEWCTR") (strcat "\n ENTER VALOR OFFSERT: <" (rtos (getvar "offset)) ">: ")))
Certain of his understanding, and my sincere appreciation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ROAD ( / js n AcDoc Space ll ur t_width nw_obj att_pt t_ang m_pt nw_objename obj pr nb typ_obj
   oldim oldlay a_base a_dir pt_start pt_end pt_cen
  rad alpha pt_vtx dist_start dist_end seg_len seg_bulge)
 (defun TGTEXTO (ins_txt value_str a / nw_obj)
    (setq nw_obj (vla-addMtext Space (vlax-3d-point (trans ins_txt 1 0)) 0.0 value_str))
 ;;;      (setq nw_obj (vla-addmtext Space (vlax-3d-point m_pt) 0.0 value_str))
 ;;;      (vla-getboundingbox nw_obj 'll 'ur)
 ;;;      (setq ll (vlax-safearray->list ll)
 ;;;            ur (vlax-safearray->list ur)     
 ;;;            t_width (+ (* (distance ll ur) (cos (angle ll ur))) 5.0)
 ;;;      );end_setq
 ;;;      (if (>= t_width seg_len)
 ;;;        (setq att_pt 5
 ;;;              t_width seg_len
 ;;;        );end_setq
 ;;;        (setq att_pt 8
 ;;;  m_pt (polar m_pt (+ t_ang (/ pi 2)) (* (getvar 'TEXTSIZE) 10)) This is the value that controls the OFFSET of the text
 ;;;        );end_setq
 ;;;      );end_if      
      (mapcar '(lambda (pr val) (vlax-put nw_obj pr val))
      (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
      (list 5 (getvar "TEXTSIZE") 5 ins_txt "TGDdim" "TGCOTA" (if (and (< a (* pi 0.5)) (> a (* pi 1.5))) (setq a (+ a pi)) a)) )
    (entmod
      (append
      (vl-remove-if
        (function
          (lambda (x)
            (or (member (car x) '(90 63 421 45))
              (< 419 (car x) 440))))
        (entget (entlast)))
      (list
        '(90 . 1)
        '(63 . 41)
        '(421 . 16770196)
        '(45 . 1.5) ) ) )
    (entupd (entlast)))
  (princ "\nSelect polylines/Arc : ")
  (setq
    js
    (ssget
      '((-4 . "<OR")
        (-4 . "<AND")
          (0 . "POLYLINE")
          (-4 . "<NOT")
            (-4 . "&") (70 . 126)
          (-4 . "NOT>")
        (-4 . "AND>")
        (0 . "LWPOLYLINE,ARC")
        (-4 . "OR>"))
    )
    n -1
  )
  (cond
    (js
      (setq
        AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
        Space
          (if (= 1 (getvar "CVPORT"))
            (vla-get-PaperSpace AcDoc)
            (vla-get-ModelSpace AcDoc) ) nb 0 )
      (cond
        ((null (tblsearch "LAYER" "TGCOTA"))
          (vlax-put (vla-add (vla-get-layers AcDoc) "TGCOTA") 'Color 7) ) )
      (cond
        ((null (tblsearch "STYLE" "TGDdim"))
          (setq nw_style (vla-add (vla-get-textstyles AcDoc) "TGDdim")
                nw_font (strcat (getenv "systemroot") "\\Fonts\\Arial.ttf") )
          (mapcar '(lambda (pr val) (vlax-put-property nw_style pr val))
               (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
               (list nw_font 0.0 (/ (* 0.0 pi) 180) 1.0 0.0) ) ) )
      (setq
  oldim   (getvar "dimzin")
  oldlay   (getvar "clayer")
  a_base   (getvar "ANGBASE")
  a_dir   (getvar "ANGDIR")
      )
      (setvar "dimzin" 0) (setvar "clayer" "TGCOTA")
      (setvar "ANGBASE" 0) (setvar "ANGDIR" 0)
      (initget 6)
      (setq h_t (getdist (getvar "VIEWCTR") (strcat "\nTaille du texte <" (rtos (getvar "textsize")) ">: ")))
      (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))
      (repeat (sslength js)
        (setq
          ename (ssname js (setq n (1+ n)))
          obj (vlax-ename->vla-object ename) pr -1 nb 0 )
        (setq typ_obj (vla-get-ObjectName obj))
        (if (eq typ_obj "AcDbArc")
          (progn
            (setq
              pt_start   (vlax-get obj 'StartPoint)
              pt_end   (vlax-get obj 'EndPoint)
              pt_cen   (vlax-get obj 'Center)
              rad   (vlax-get obj 'Radius)
              alpha   (* (vlax-get obj 'TotalAngle) 0.5)
              seg_len   (vlax-get obj 'ArcLength)
              pt_vtx   (polar pt_cen (+ (vlax-get obj 'StartAngle) alpha) (+ rad (* rad (1- (/ 1 (cos alpha))))))
              nb   (1+ nb))
            (TGTEXTO
              (mapcar '* (mapcar '+ pt_start pt_end) '(0.5 0.5 0.5))
              (strcat
                "{\\fArial Narrow|b0|i0|c0|p34;"
                "CURVE N+"  (itoa nb)
                "\\P AC:"  (angtos (- pi (* 2 alpha)) 0 4)
                "%%ddm\\P TG:"  (rtos (distance pt_start pt_vtx) 2 3)
                "m\\P RAY:"  (rtos rad 2 3)
                "m\\P DISTANCE:" (rtos seg_len 2 3) "m" "}" ) (angle pt_start pt_end) ) )
          (repeat (fix (vlax-curve-getEndParam obj))
            (setq
  dist_start  (vlax-curve-GetDistAtParam obj (setq pr (1+ pr)))
  dist_end  (vlax-curve-GetDistAtParam obj (1+ pr))
  pt_start    (vlax-curve-GetPointAtParam obj pr)
  pt_end   (vlax-curve-GetPointAtParam obj (1+ pr))
  seg_len  (- dist_end dist_start)
  seg_bulge  (vla-GetBulge obj pr) )
            (if (not (zerop seg_bulge))
              (progn
                (setq
  rad   (/ seg_len (* 4.0 (atan seg_bulge)))
  alpha   (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge))))
  pt_cen   (polar pt_start alpha rad)
  pt_vtx   (polar pt_start (- alpha (* pi 0.5)) (* rad (/ (sin (* 2.0 (atan seg_bulge))) (cos (* 2.0 (atan seg_bulge))))))
  alpha   (if (< (* 2.0 (atan seg_bulge)) 0) (- pi (* 2.0 (atan seg_bulge))) (* 2.0 (atan seg_bulge)))
  nb    (1+ nb))
                (TGTEXTO
                  (vlax-curve-GetPointAtParam obj (+ 0.5 pr))
                  (strcat
  "{\\fArial Narrow|b0|i0|c0|p34;"
  "CURVE "  (itoa nb)
  "\\P AC:"  (angtos (- pi (* 2 alpha)) 0 4)
  "%%ddm\\P TG:" (rtos (distance pt_start pt_vtx) 2 3)
  "m\\P RAY:"  (rtos rad 2 3)
  "m\\P DISTANCE:" (rtos seg_len 2 3) "m" "}" )
                  (angle pt_start pt_end) ) )
              (TGTEXTO
                (vlax-curve-GetPointAtParam obj (+ 0.5 pr))
                (strcat
  "{\\fArial Narrow|b0|i0|c0|p34;"
  "DISTANCE "   (rtos seg_len 2 3)
  "m\\P Az:"   (vl-string-subst "%%d" "d" (angtos (+ (angle pt_start pt_end) (- (* pi 0.5) (* 2.0 (atan seg_bulge)))) 1 4)) "}"
                )
                (angle pt_start pt_end)
              )
            )
          )
        )
      )
      (setvar "dimzin" oldim) (setvar "clayer" oldlay)
      (setvar "ANGBASE" a_base) (setvar "ANGDIR" a_dir)
    )
  )
  (prin1)
)
0 Likes
Like
Report
Report a website issue