Jump to content

Custom polyLine with text


cadmando2

Recommended Posts

is it possable to create a custom polyline to attach in information to it like "pipe size" "lenth" "HWS" "HWR".

what I'm looking to do is draw a Piping, Electrical wire or single line duct layout with the info above the pline! or even edit the info. what would be nice is to draw pline and go back over and select the pline and the info would be place over the pline or option to have leader line with the info!

can anyone help me!

Ployline.jpg

Link to comment
Share on other sites

As suggest, would you post here a drawing before and after revised, with drawing I easy to understand.

 

is it possable to create a custom polyline to attach in information to it like "pipe size" "lenth" "HWS" "HWR".

what I'm looking to do is draw a Piping, Electrical wire or single line duct layout with the info above the pline! or even edit the info. what would be nice is to draw pline and go back over and select the pline and the info would be place over the pline or option to have leader line with the info!

can anyone help me!

Link to comment
Share on other sites

I wrote this some time ago for one guy

from discussion.group forum

Here are two lisps just slightly edited to your suit,

the first one will add the extended data to the selected pipes,

and the second will draw the table and populate

them with extended data

 

;; first lisp
;; xar.lsp
;; first select one by one all what you need with accuracy
;; and add xdata
(vl-load-com)

(defun C:XAR (/	)

(setq osm (getvar "osmode")); store osmode
(setvar "osmode" 512)
(setvar "cmdecho" 0); turn echo off
(regapp "PIPEINFO"); first of register application in ACAD.
;; This would be stored in the table APPID
;; loop through selected plines:
(while
(setq pickpt (getpoint "\nPick point on pline (hit Enter to exit loop): ")); pick point on entity
(setq ps  (getreal "\nPipe size: ")
     ln   (getreal "\nLength: ")
     hws (getstring T "\nHWS: ")
     hwr  (getstring T "\nHWR: ")
     )

(setq en (ssname (ssget "C" pickpt pickpt (list (cons 0 "*POLYLINE")))0))

(setq elist (entget en))
;build extension data 
(setq
xdata (list
(list -3 (list "PIPEINFO"
       (cons 1040 ps);real
       (cons 1041 ln);distance
       (cons 1000 hws);string	       
       (cons 1000 hwr);string	       
       ))
)
)
(setq xdlist (append elist xdata));append extension data to entity list
(entmod xdlist); setting data, modify entity list
(entupd en); update entity, optonal
); end loop
(setvar "osmode" osm); restore osmode
(setvar "cmdecho" 1); turn echo on
 (princ)
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with XAR to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)


;; second lisp
;; art.lsp

;; here is follows part to draw the table

 (vl-load-com)

;; local defuns:

; read extension data:
(defun get_xdata (vobj apname)
(or (vl-load-com))
(if (and vobj apname)
(progn
(vla-getxdata vobj apname 'xtypeOut 'xdataOut) 
(setq xtp (vlax-safearray->list xtypeOut))
(setq dtp (mapcar (function (lambda (x)
	(vlax-variant-value x)))
	  (vlax-safearray->list xdataOut)))
dtp
)
)
)

;Then you can get all xdata:
(defun getallxdata (appname / acapp adoc axss table_data tmp)
 (or (vl-load-com))
 (or acapp (setq acapp (vlax-get-acad-object)))
 (or adoc (setq adoc (vla-get-activedocument acapp)))
 (if (ssget "X" (list (cons 0  "*POLYLINE")
	       (list -3 (list appname))))
   (progn
   (setq axss (vla-get-activeselectionset adoc))
   (vlax-for a axss
     (if
     (setq tmp (cdr (get_xdata a appname)))
     (setq table_data (cons tmp table_data))))))
   (reverse table_data)
 )

;; create table style

(defun make-tablestyle ( name desc txtstyle h1 h2 h3 / tblstyle adoc)
 (or (vl-load-com))
 (setq 
   tblstyle (vla-addobject 
     (vla-item (vla-get-dictionaries 
            (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
            ) 
          "Acad_Tablestyle" 
          ) 
     name 
     "AcDbTableStyle" 
     ) 
   )
 (setq acmCol (vla-getinterfaceobject
       (vlax-get-acad-object)
       (strcat "AutoCAD.AcCmColor."
	       (substr (getvar "ACADVER") 1 2))))  
 (vla-put-name tblstyle name)
 
 (vla-put-headersuppressed tblstyle :vlax-false) 
 (vla-put-titlesuppressed tblstyle :vlax-false)
 (vla-put-description tblstyle desc) 
 (vla-put-flowdirection tblstyle 0)
 (vla-put-bitflags tblstyle 1)
 (vla-put-horzcellmargin tblstyle (/ h3 5))  
 (vla-put-vertcellmargin tblstyle (/ h3 5))
 (vla-settextstyle tblstyle 7 txtstyle)
 (vla-settextheight tblstyle 1 h3)  
 (vla-settextheight tblstyle 4 h2) 
 (vla-settextheight tblstyle 2 h1) 

 (vla-setrgb acmCol 204 102 0)
 (vla-setgridcolor tblstyle 63 7 acmCol)
 
 (vla-setgridvisibility tblstyle 63 7 :vlax-true) 
 (vla-setgridlineweight  tblstyle 18 7 aclnwt009) 
 (vla-setgridlineweight tblstyle 45 7 aclnwt050) 

 (vlax-release-object acmCol)
 )
;==================== * main part * ========================;

;=========== * create table from extended data * ===========;

(defun C:ART (/ Acmcol Acsp Adoc Axss Col Columns Dht Headers Ipt Objtable Row Rows Table_Data)
 (if (< (atof (getvar "ACADVER")) 16.0)
 (alert "This routine will work\nfor versions A2005 and higher")
 (progn
 (alert "\tBe patience\n\tWorks slowly")

 (or adoc
   (setq adoc (vla-get-activedocument
 (vlax-get-acad-object))))
 (or acsp (setq acsp (if (= (getvar "TILEMODE") 0)
 (vla-get-paperspace
 adoc)
 (vla-get-modelspace
 adoc))
 )
 )
 (vl-catch-all-apply (function (lambda()
 (make-tablestyle "PipeInfo" "Electric Table" "Standard" 10.0 10.0 12.0))))
 (setq acmCol (vla-getinterfaceobject
       (vlax-get-acad-object)
       (strcat "AutoCAD.AcCmColor."
	       (substr (getvar "ACADVER") 1 2))))
 (setq dht (getvar "dimtxt"))

;;;  (setq lst_count nil)
 (setq table_data (getallxdata "PIPEINFO"))
 (setq table_data (mapcar (function (lambda(x)
	   (mapcar 'vl-princ-to-string x)))
		   table_data))
(setq	columns	 (length (car table_data)) 
rows	 (length table_data)
ipt (getpoint "\nUpper left table insertion point: \n")
 )

     (setq objtable (vlax-invoke
	      acsp
	      "AddTable"
	      ipt
	      (+ 2 rows)
	      columns
	 ;; rows height (change by suit):
	 (* dht 1.667);28
	 ;; columns width (change by suit):
	 (* dht 10);50
       )
      )
 (vla-put-regeneratetablesuppressed objtable :vlax-true)
 (vla-put-titlesuppressed objtable :vlax-false)
 (vla-put-headersuppressed objtable :vlax-false)  

 (vla-put-titlesuppressed objtable :vlax-false)
 (vla-put-headersuppressed objtable :vlax-false)
 (vla-put-horzcellmargin objtable (* dht 0.5))
 (vla-put-vertcellmargin objtable (* dht 0.5))
 (vla-put-layer objtable "0")
 (vla-settextstyle objtable 2 "Standard")
 (vla-settextstyle objtable 4 "Standard")
 (vla-settextstyle objtable 1 "Standard")
 
 (vla-setrowheight objtable 1 (* dht 1.5))
 (vla-setrowheight objtable 2 (* dht 1.25))

 
 (vla-settextheight objtable 2 (* dht 1.25))
 (vla-settextheight objtable 4 dht)
 (vla-settextheight objtable 1 dht)
 
 (vla-put-colorindex acmcol 256)
 (vla-put-truecolor objtable acmcol)
 
 (vla-setcolumnwidth objtable 0 (* dht 10))
 (vla-setcolumnwidth objtable 1 (* dht 15))
 (vla-setcolumnwidth objtable 2 (* dht 10))
 (vla-setcolumnwidth objtable 3 (* dht 15))
 
 (vla-put-colorindex acmcol 2)
 (vla-settext objtable 0 0 "Pipes Info") 
 (vla-setcelltextheight objtable 0 0 (* dht 1.5))
 (vla-setcellcontentcolor objtable 0 0 acmcol)
 (vla-put-colorindex acmcol 102)
 (setq	headers	'("Pipe Size" "Length" "HWS" "HWR")
 )
 
 (setq	col 0
row 1
 )
 (foreach a headers
   (vla-settext objtable row col a)
   (vla-setcelltextheight objtable row col (* dht 1.25))
   (vla-setcellcontentcolor objtable row col acmcol)
   (setq col (1+ col))
 )
(vla-put-colorindex acmcol 40)  
(setq  row 2 col 0)

 (foreach i table_data
 (vla-setrowheight objtable row (* dht 1.25))  
 (setq col 0)
 (foreach a i
   (vla-settext objtable row col a)
   (if (/= col 1)
   (vla-setcellalignment objtable row col acMiddleLeft)
   (vla-setcellalignment objtable row col acMiddleCenter))
   (vla-setcellcontentcolor objtable row col acmcol)
   (setq col (1+ col)))
   (setq row (1+ row))
   )
 (vla-put-colorindex acmcol 12)

 (vla-setcellcontentcolor objtable row 1 acmcol)
 (vla-put-regeneratetablesuppressed objtable :vlax-false)
 (vl-catch-all-apply
   (function
     (lambda ()
(progn
  (vla-clear axss)
  (vla-delete axss)
  (mapcar 'vlax-release-object (list axss objtable))
  )
)
     )
   )
 (vla-regen adoc acactiveviewport)
 (alert "Done")
 )
   )
 (princ)
)

(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with ART to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)

 

~'J'~

Link to comment
Share on other sites

Thanks for the code.

is this code you wrote, what verision of cad will it work with!

I'm using autoCAD 2004 and when I loaded the code and type in xar and selected pline or line I got is error!

; error: bad DXF group: (-3 ("PIPEINFO" (1040 . 3.0) (1041) (1000 . "") (1000 .

"HWR")))

 

type in art and got this Error.

; error: ActiveX Server returned the error: unknown name: "AddTable"

Link to comment
Share on other sites

I'm not sure about but I think that

AcadTable object was embedded into

AutoCAD starting from A2006 version only

You need to draw instead the plain table

with using of lines

I have the similar programm that will do it

but I need a time to rewrite them to this

suit.

Perhaps tomorrow I'll free for this work

Later,

 

~'J'~

Link to comment
Share on other sites

Thanks for the code.

is this code you wrote, what verision of cad will it work with!

I'm using autoCAD 2004 and when I loaded the code and type in xar and selected pline or line I got is error!

; error: bad DXF group: (-3 ("PIPEINFO" (1040 . 3.0) (1041) (1000 . "") (1000 .

"HWR")))

 

type in art and got this Error.

; error: ActiveX Server returned the error: unknown name: "AddTable"

Okay, I have to rewrote it for your version

Give this a try

 

;; xar.lsp
;; first select one by one all what you need with accuracy
;; and add xdata
(vl-load-com)

(defun C:XAR (/	)

(setq osm (getvar "osmode")); store osmode
(setvar "osmode" 512)
(setvar "cmdecho" 0); turn echo off
(regapp "PIPEINFO"); first of register application in ACAD.
;; This would be stored in the table APPID
;; loop through selected enforcements:
(while
(setq pickpt (getpoint "\nPick point on enforcement: ")); pick point on entity
(setq ps  (getreal "\nPipe size: ")
     ln   (getreal "\nLength: ")
     hws (getstring T "\nHWS: ")
     hwr  (getstring T "\nHWR: ")
     )

(setq en (ssname (ssget "C" pickpt pickpt (list (cons 0 "*POLYLINE")))0))

(setq elist (entget en))
;build extension data 
(setq
xdata (list
(list -3 (list "PIPEINFO"
       (cons 1040 ps);real
       (cons 1041 ln);distance
       (cons 1000 hws);string	       
       (cons 1000 hwr);string	       
       ))
)
)
(setq xdlist (append elist xdata));append extension data to entity list
(entmod xdlist); setting data, modify entity list
(entupd en); update entity, optonal
); end loop
(setvar "osmode" osm); restore osmode
(setvar "cmdecho" 1); turn echo on
 (princ)
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with XAR to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)


;; second lisp

;; ptd.lsp

(vl-load-com)

;; local defuns:

; read extension data:
(defun get_xdata (vobj apname)
(or (vl-load-com))
(if (and vobj apname)
(progn
(vla-getxdata vobj apname 'xtypeOut 'xdataOut) 
(setq xtp (vlax-safearray->list xtypeOut))
(setq dtp (mapcar (function (lambda (x)
	(vlax-variant-value x)))
	  (vlax-safearray->list xdataOut)))
dtp
)
)
)

;Then you can get all xdata:
(defun getallxdata (appname / acapp adoc axss table_data tmp)
 (or (vl-load-com))
 (or acapp (setq acapp (vlax-get-acad-object)))
 (or adoc (setq adoc (vla-get-activedocument acapp)))
 (if (ssget "X" (list (cons 0  "*POLYLINE")
	       (list -3 (list appname))))
   (progn
   (setq axss (vla-get-activeselectionset adoc))
   (vlax-for a axss
     (if
     (setq tmp (cdr (get_xdata a appname)))
     (setq table_data (cons tmp table_data))))))
   (reverse table_data)
 )

(defun C:PTD (/	cnt	     com_height	  dht	       num	    p0		 rows	      row_height   table_data
	table_headers		  table_height title_height title_text_height	      tmp	   txt_line
	txt_xpos     wid	  wids	       x	    y)


 (setq table_data (getallxdata "PIPEINFO"))
 (setq table_data (mapcar (function (lambda(x)
	   (mapcar 'vl-princ-to-string x)))
		   table_data))
 (setq table_headers
'("Pipe Size" "Length" "HWS" "HWR"))
;;==================TABLE CALCULATION=====================;;
(setq dht (getvar "textsize")
     title_text_height (* dht 1.5)
     row_height (* dht 2.)
     title_height (* row_height 1.5)
     rows (length table_data))
 (setq cnt 0)
 (repeat (length table_headers)
   (setq tmp (* (strlen (nth cnt table_headers)) dht 1.25)
  wids (cons tmp wids)
  tmp nil
  cnt (1+ cnt)))
 (setq wids (reverse wids)
wid (apply '+ wids))
 (setq p0 (getpoint "\nSpecify upper left point of table : \n"))
 (setq x (car p0)
y (cadr p0)
txt_xpos (append (list 0.0)(reverse (cdr (reverse wids)))))

;;========================TITLE=========================;;
 (entmake
     (list '(0 . "LINE") (cons 10  p0)
    (cons 11 (list (+ x wid) y))))
 (setq y (- y  title_height))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
    (cons 11 (list (+ x wid) y))))
 (entmake (list '(0 . "TEXT")(cons 1 "Pipes Info")
 (cons 10 (list (+ x (/ wid 2)(/ dht 2))
	 (+ y (/ dht 2))))
 (cons 11 (list (+ x (/ wid 2)(/ dht 2))
	 (+ y (/ dht 2))))
   (cons 40 title_text_height) '(71 . 0)'(72 . 1)'(73 . 0)))
 ;;========================HEADER=========================;;
 (setq cnt 0 y (- y row_height))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
    (cons 11 (list (+ x wid) y))))
 (repeat (length table_headers)
   (setq x (+ x (nth cnt txt_xpos)))
 (entmake (list '(0 . "TEXT")(cons 1 (nth cnt table_headers))
 (cons 10 (list (+ x (/ dht 2))
	 (+ y (/ dht 2))))
   (cons 40 dht) '(72 . 0)))
   (setq cnt (1+ cnt)))
 ;;========================TABLE=========================;;
 (setq num 0 x (car p0) y (- y row_height))
 (repeat rows
   (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
    (cons 11 (list (+ x wid) y))))
   (setq txt_line (nth num table_data)
  cnt 0)
   (repeat (length txt_line)
     (setq x (+ x (nth cnt txt_xpos)))
     (entmake (list '(0 . "TEXT")(cons 1 (nth cnt txt_line))
 (cons 10 (list (+ x (/ dht 2))
	 (+ y (/ dht 2))))
   (cons 40 dht) '(72 . 0)))
     (setq cnt (1+ cnt)))
   (setq num (1+ num)
  x (car p0)
  y (- y row_height)))
 ;;===============VERTICAL LINES=================;;
 (setq table_height (* (1+ rows) row_height)
com_height (+ table_height title_height))
 (entmake
     (list '(0 . "LINE") (cons 10  p0)
    (cons 11 (list x (- (cadr p0) com_height)))))
 (entmake
     (list '(0 . "LINE") (cons 10  (list (+ x wid)(cadr p0)))
    (cons 11 (list (+ x wid) (- (cadr p0) com_height)))))
 (setq txt_xpos (cdr txt_xpos))
 (setq cnt 0)
 (repeat (length txt_xpos)
   (setq x (+ x (nth cnt txt_xpos)))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x (- (cadr p0) title_height )))
    (cons 11 (list x (- (cadr p0) title_height table_height)))))
   (setq cnt (1+ cnt)
  ))
   (alert "Done")

 (princ)
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with PTD to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)

 

 

~'J'~

Link to comment
Share on other sites

  • 3 years later...

Very interesting and useful lisp.

I would be interested to enter data using DCL (see dwg).

I'm use Acad2008.

Best Regards.

 

 

 

 

Okay, I have to rewrote it for your version

Give this a try

 

;; xar.lsp
;; first select one by one all what you need with accuracy
;; and add xdata
(vl-load-com)

(defun C:XAR (/    )

(setq osm (getvar "osmode")); store osmode
(setvar "osmode" 512)
(setvar "cmdecho" 0); turn echo off
(regapp "PIPEINFO"); first of register application in ACAD.
;; This would be stored in the table APPID
;; loop through selected enforcements:
(while
(setq pickpt (getpoint "\nPick point on enforcement: ")); pick point on entity
(setq ps  (getreal "\nPipe size: ")
     ln   (getreal "\nLength: ")
     hws (getstring T "\nHWS: ")
     hwr  (getstring T "\nHWR: ")
     )

(setq en (ssname (ssget "C" pickpt pickpt (list (cons 0 "*POLYLINE")))0))

(setq elist (entget en))
;build extension data 
(setq
xdata (list
(list -3 (list "PIPEINFO"
          (cons 1040 ps);real
          (cons 1041 ln);distance
          (cons 1000 hws);string           
          (cons 1000 hwr);string           
          ))
)
)
(setq xdlist (append elist xdata));append extension data to entity list
(entmod xdlist); setting data, modify entity list
(entupd en); update entity, optonal
); end loop
(setvar "osmode" osm); restore osmode
(setvar "cmdecho" 1); turn echo on
 (princ)
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with XAR to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)


;; second lisp

;; ptd.lsp

(vl-load-com)

;; local defuns:

; read extension data:
(defun get_xdata (vobj apname)
(or (vl-load-com))
(if (and vobj apname)
(progn
(vla-getxdata vobj apname 'xtypeOut 'xdataOut) 
(setq xtp (vlax-safearray->list xtypeOut))
(setq dtp (mapcar (function (lambda (x)
       (vlax-variant-value x)))
         (vlax-safearray->list xdataOut)))
dtp
)
)
)

;Then you can get all xdata:
(defun getallxdata (appname / acapp adoc axss table_data tmp)
 (or (vl-load-com))
 (or acapp (setq acapp (vlax-get-acad-object)))
 (or adoc (setq adoc (vla-get-activedocument acapp)))
 (if (ssget "X" (list (cons 0  "*POLYLINE")
              (list -3 (list appname))))
   (progn
   (setq axss (vla-get-activeselectionset adoc))
   (vlax-for a axss
     (if
     (setq tmp (cdr (get_xdata a appname)))
     (setq table_data (cons tmp table_data))))))
   (reverse table_data)
 )

(defun C:PTD (/    cnt         com_height      dht           num        p0         rows          row_height   table_data
       table_headers          table_height title_height title_text_height          tmp       txt_line
       txt_xpos     wid      wids           x        y)


 (setq table_data (getallxdata "PIPEINFO"))
 (setq table_data (mapcar (function (lambda(x)
          (mapcar 'vl-princ-to-string x)))
              table_data))
 (setq table_headers
'("Pipe Size" "Length" "HWS" "HWR"))
;;==================TABLE CALCULATION=====================;;
(setq dht (getvar "textsize")
     title_text_height (* dht 1.5)
     row_height (* dht 2.)
     title_height (* row_height 1.5)
     rows (length table_data))
 (setq cnt 0)
 (repeat (length table_headers)
   (setq tmp (* (strlen (nth cnt table_headers)) dht 1.25)
     wids (cons tmp wids)
     tmp nil
     cnt (1+ cnt)))
 (setq wids (reverse wids)
   wid (apply '+ wids))
 (setq p0 (getpoint "\nSpecify upper left point of table : \n"))
 (setq x (car p0)
   y (cadr p0)
   txt_xpos (append (list 0.0)(reverse (cdr (reverse wids)))))

;;========================TITLE=========================;;
 (entmake
     (list '(0 . "LINE") (cons 10  p0)
       (cons 11 (list (+ x wid) y))))
 (setq y (- y  title_height))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
       (cons 11 (list (+ x wid) y))))
 (entmake (list '(0 . "TEXT")(cons 1 "Pipes Info")
 (cons 10 (list (+ x (/ wid 2)(/ dht 2))
        (+ y (/ dht 2))))
 (cons 11 (list (+ x (/ wid 2)(/ dht 2))
        (+ y (/ dht 2))))
      (cons 40 title_text_height) '(71 . 0)'(72 . 1)'(73 . 0)))
 ;;========================HEADER=========================;;
 (setq cnt 0 y (- y row_height))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
       (cons 11 (list (+ x wid) y))))
 (repeat (length table_headers)
   (setq x (+ x (nth cnt txt_xpos)))
 (entmake (list '(0 . "TEXT")(cons 1 (nth cnt table_headers))
 (cons 10 (list (+ x (/ dht 2))
        (+ y (/ dht 2))))
      (cons 40 dht) '(72 . 0)))
   (setq cnt (1+ cnt)))
 ;;========================TABLE=========================;;
 (setq num 0 x (car p0) y (- y row_height))
 (repeat rows
   (entmake
     (list '(0 . "LINE") (cons 10  (list x y))
       (cons 11 (list (+ x wid) y))))
   (setq txt_line (nth num table_data)
     cnt 0)
   (repeat (length txt_line)
     (setq x (+ x (nth cnt txt_xpos)))
     (entmake (list '(0 . "TEXT")(cons 1 (nth cnt txt_line))
 (cons 10 (list (+ x (/ dht 2))
        (+ y (/ dht 2))))
      (cons 40 dht) '(72 . 0)))
     (setq cnt (1+ cnt)))
   (setq num (1+ num)
     x (car p0)
     y (- y row_height)))
 ;;===============VERTICAL LINES=================;;
 (setq table_height (* (1+ rows) row_height)
   com_height (+ table_height title_height))
 (entmake
     (list '(0 . "LINE") (cons 10  p0)
       (cons 11 (list x (- (cadr p0) com_height)))))
 (entmake
     (list '(0 . "LINE") (cons 10  (list (+ x wid)(cadr p0)))
       (cons 11 (list (+ x wid) (- (cadr p0) com_height)))))
 (setq txt_xpos (cdr txt_xpos))
 (setq cnt 0)
 (repeat (length txt_xpos)
   (setq x (+ x (nth cnt txt_xpos)))
 (entmake
     (list '(0 . "LINE") (cons 10  (list x (- (cadr p0) title_height )))
       (cons 11 (list x (- (cadr p0) title_height table_height)))))
   (setq cnt (1+ cnt)
     ))
   (alert "Done")

 (princ)
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
(prompt
 "\n\t\t\t  <|  Start with PTD to execute  |>"
)
(prompt
 "\n\t\t\t   |-----------------------------|"
)
 (princ)

~'J'~

Water Network.dwg

Link to comment
Share on other sites

This will get you started, do rest your work by yourself

I have not have a time on this work

(vl-load-com)
(defun run-dialog  (leng /)
 (setq fn (strcat (getvar "dwgprefix")
    (getvar "dwgname")
    "waterparams.dcl")
fd (open fn "w"))
 (mapcar
   (function
     (lambda (x)
(princ x fd)
(princ "\n" fd)
)
     )
   (list
     "water : dialog {label=\"Parameters\";"
     "fixed_width_font=true;"
     ": edit_box{label=\"Street\";"
     "fixed_width_font=true;"
     "key = \"street\";}"
     ": edit_box{label=\"Length\";"
     "fixed_width_font=true;"
     (strcat "value=" leng ";")
     "key = \"leng\";}"
     ": list_box {label=\"Math\";"
     "fixed_width_font=true;"
     "key = \"math\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     ": list_box {label=\"Dia.\";"
     "fixed_width_font=true;"
     "key = \"dia\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     "ok_cancel;"
     "}"
     )
   )
 (close fd)
 (princ)
 )
(defun C:demo  (/
 dcl_id
 dial
 dia_list
 dia_val
 en
 ent
 fn
 leng
 math_list
 math_val
 pick)
 (vl-load-com)
 (while (setq ent (entsel "\nSelect pipe-line (or hit Enter to Exit): "))
   (if
     (member (strcase (cdr (assoc 0 (entget (car ent)))))
      (list "LWPOLYLINE" "SPLINE"))
      (progn
 (setq en (car ent))
 (setq leng (vlax-curve-getdistatparam en (vlax-curve-getendparam en)))
 (run-dialog (rtos leng 2 3))
 (if (not (setq dcl_id (load_dialog fn)))
   (exit))
 (if (not (new_dialog "water" dcl_id))
   (exit))
 (start_list "math")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq math_list
   (list 1.05 1.1 1.15 1.2 1.25 1.3 1.35))))
 (end_list)
 (start_list "dia")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq dia_list
   (list 12.0 24.0 36.0 48.0 60.0))))
 (end_list)
 (action_tile
   "accept"
   (strcat "(progn "
    "(setq str_val (get_tile \"street\"))"
    "(setq leng_val (get_tile \"leng\"))"
    "(setq math_val (atoi (get_tile \"math\")))"
    "(setq dia_val (atoi (get_tile \"dia\")))"
    "(done_dialog 1))")
   )
 (action_tile "cancel" "(done_dialog 0)")
 (setq pick (start_dialog))
 (unload_dialog dcl_id)
 (vl-file-delete fn)
 (if (and (= 1 pick) str_val leng_val math_val dia_val)
   (progn
     (alert
       (strcat "Street: "
        (vl-princ-to-string str_val)
        "\n"
        "Length : "
        (vl-princ-to-string (atof leng_val))
        "\n"
        "Math: "
        (vl-princ-to-string (setq mat_val (nth math_val math_list)))
        "\n"
        "Dia : "
        (vl-princ-to-string (setq dia_val (nth dia_val dia_list))))
       )
     ;;...[ rest your code goes here ]...
     )
   )
 )
     )
   )
 (princ)
 )

Link to comment
Share on other sites

  • 2 months later...

Mr. Fixo,

I tried to finish your lisp.

I failed.

It seems to learn the programming language I need some time and perfect understanding of system variables.

If you can finish (please), will remain Grateful.

Sincerely,

Link to comment
Share on other sites

Mr. Fixo,

I tried to finish your lisp.

I failed.

It seems to learn the programming language I need some time and perfect understanding of system variables.

If you can finish (please), will remain Grateful.

Sincerely,

 

I wiil be try do finish this code tomorrow , not sure about my free time

Link to comment
Share on other sites

Try again

;; local defuns
(vl-load-com)
(defun run-dialog  (leng /)
 (setq fn (strcat (getvar "dwgprefix")
    (getvar "dwgname")
    "waterparams.dcl")
fd (open fn "w"))
 (mapcar
   (function
     (lambda (x)
(princ x fd)
(princ "\n" fd)
)
     )
   (list
     "water : dialog {label=\"Parameters\";"
     "fixed_width_font=true;"
     ": edit_box{label=\"Street\";"
     "fixed_width_font=true;"
     "key = \"street\";}"
     ": edit_box{label=\"Length\";"
     "fixed_width_font=true;"
     (strcat "value=" (rtos leng 2 3) ";")
     "key = \"leng\";}"
     ": list_box {label=\"Math\";"
     "fixed_width_font=true;"
     "key = \"math\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     ": list_box {label=\"Dia.\";"
     "fixed_width_font=true;"
     "key = \"dia\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     "ok_cancel;"
     "}"
     )
   )
 (close fd)
 (princ)
 )
;; convert radians to degrees
(defun rtd (rad)
 (/ (* rad 180) pi)
)

;; main part
(defun C:PPW  (/ *error* ang cl cr curve dcl_id dia dia_list dia_val
 en ent fn fst info leng leng_val lpt lpt1 lpt2 mat math_list
 math_val mat_val osm pick pt snd str_val txh txst upt)
 (vl-load-com)
  (defun *error*  (msg)
    (if msg(princ msg))
    ;; stop any command
    (while (/= (getvar "cmdactive") 0) (command))
    ;;restore variables
    (if osm
      (setvar "osmode" osm))
    (if cl
      (setvar "clayer" cl))
    (if cr
      (setvar "cecolor" cr))
    (if txst
      (setvar "textstyle" txst))
    (if txh
      (setvar "textsize" txh))
    (command "._undo" "E")
)
(setq osm (getvar "osmode"))
 (setq cl (getvar "clayer"))
 (setq cr (getvar "cecolor"))
 (setq txst (getvar "textstyle"))
 (setq txh(getvar "textsize"))

(command "._undo" "BE")
 (setvar "osmode" 0)
 (setvar "textsize" 50.0)
 (while (setq ent (entsel "\nSelect pipe-line (or hit Enter to Exit): "))
   (if
     (member (strcase (cdr (assoc 0 (entget (car ent)))))
      (list "LWPOLYLINE" "SPLINE"))
      (progn
 (setq en (car ent))
 (setq curve (vlax-ename->vla-object en))
 (setq pt (vlax-curve-getclosestpointto en (cadr ent)))
 (setq leng (vlax-curve-getdistatparam en (vlax-curve-getendparam en)))
 (run-dialog leng )
 (if (not (setq dcl_id (load_dialog fn)))
   (exit))
 (if (not (new_dialog "water" dcl_id))
   (exit))
 (start_list "math")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq math_list
   (list "AB" "CD" "EF" "GH"))))
 (end_list)
 (start_list "dia")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq dia_list
   (list 100 200 300 400 500))))
 (end_list)
 (action_tile
   "accept"
   (strcat "(progn "
    "(setq str_val (get_tile \"street\"))"
    "(setq leng_val (get_tile \"leng\"))"
    "(setq math_val (atoi (get_tile \"math\")))"
    "(setq dia_val (atoi (get_tile \"dia\")))"
    "(done_dialog 1))")
   )
 (action_tile "cancel" "(done_dialog 0)")
 (setq pick (start_dialog))
 (unload_dialog dcl_id)
 (vl-file-delete fn)
 (if (and (= 1 pick) str_val leng_val math_val dia_val)
   (progn
        (setq fst (vl-princ-to-string str_val))
        (setq snd (rtos (atof leng_val)2 3))
        (setq mat (vl-princ-to-string (setq mat_val (nth math_val math_list))))
        (setq dia(vl-princ-to-string (setq dia_val (nth dia_val dia_list))))

(setq  ang (angle
     '(0 0 0)
     (trans
       (vlax-curve-getfirstderiv
         curve
         (vlax-curve-getparamatpoint curve pt)
       )
       0 1 t 
     )
   )
)
(setq label
 (strcat
   "%<[url="file://\\AcObjProp"]\\AcObjProp[/url] Object(%<[url="file://\\_ObjId"]\\_ObjId[/url] "
   (itoa (vla-get-objectid curve))
   ">%).Length [url="file://\\f"]\\f[/url] \"%lu2%pr3\">%"
 )
 )
;;set text rotation angle to more readable:

(if (< (/ pi 2) ang (* pi 1.5))
 (setq ang (+ ang pi))
 )
(setq upt (polar pt (+ ang (/ pi 2)) (* (getvar "textsize") 1.5)))
(setq lpt (polar pt (- ang (/ pi 2)) (* (getvar "textsize") 1.5)))
(setq lpt1 (polar lpt (+ ang pi) (getvar "textsize")))
(setq lpt2 (polar lpt ang (getvar "textsize")))
(setq ang (rtd ang))

(setvar "cecolor" "bylayer")
(setvar "clayer" "1 Street")
(command "-mtext" "_non" upt "J" "MC" "H" 50.0 "R" ang "w" 0  fst "")      
(setvar "clayer" "2 Length")
(command "-mtext" "_non" pt "J" "MC" "H" 50.0 "R" ang "w" 0  label "")      
(setvar "clayer" "3 Mat")
  (command "-mtext" "_non" lpt1 "J" "MR" "H" 50.0 "R" ang "w" 0  mat "")   
(setvar "clayer" "4 Dia")
     (command "-mtext" "_non" lpt2 "J" "ML" "H" 50.0 "R" ang "w" 0  (strcat "%%c" dia) "")
   )
 )
     )
   )
   )
   (*error* nil)
 (princ)
 )
(princ "\n Start command with PPW")
(prin1)

Link to comment
Share on other sites

Thanks a lot.

I overcome the problem.

l do not understand VL-.... , VLA-....,VlAX-.....,

Thank you, you are a true guru.

respectfully

 

Try again

;; local defuns
(vl-load-com)
(defun run-dialog  (leng /)
 (setq fn (strcat (getvar "dwgprefix")
    (getvar "dwgname")
    "waterparams.dcl")
fd (open fn "w"))
 (mapcar
   (function
     (lambda (x)
(princ x fd)
(princ "\n" fd)
)
     )
   (list
     "water : dialog {label=\"Parameters\";"
     "fixed_width_font=true;"
     ": edit_box{label=\"Street\";"
     "fixed_width_font=true;"
     "key = \"street\";}"
     ": edit_box{label=\"Length\";"
     "fixed_width_font=true;"
     (strcat "value=" (rtos leng 2 3) ";")
     "key = \"leng\";}"
     ": list_box {label=\"Math\";"
     "fixed_width_font=true;"
     "key = \"math\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     ": list_box {label=\"Dia.\";"
     "fixed_width_font=true;"
     "key = \"dia\";"
     "multiple_select = false;"
     "height = 3.6;"
     "allow_accept = true;"
     "}"
     "ok_cancel;"
     "}"
     )
   )
 (close fd)
 (princ)
 )
;; convert radians to degrees
(defun rtd (rad)
 (/ (* rad 180) pi)
)

;; main part
(defun C:PPW  (/ *error* ang cl cr curve dcl_id dia dia_list dia_val
 en ent fn fst info leng leng_val lpt lpt1 lpt2 mat math_list
 math_val mat_val osm pick pt snd str_val txh txst upt)
 (vl-load-com)
  (defun *error*  (msg)
    (if msg(princ msg))
    ;; stop any command
    (while (/= (getvar "cmdactive") 0) (command))
    ;;restore variables
    (if osm
      (setvar "osmode" osm))
    (if cl
      (setvar "clayer" cl))
    (if cr
      (setvar "cecolor" cr))
    (if txst
      (setvar "textstyle" txst))
    (if txh
      (setvar "textsize" txh))
    (command "._undo" "E")
)
(setq osm (getvar "osmode"))
 (setq cl (getvar "clayer"))
 (setq cr (getvar "cecolor"))
 (setq txst (getvar "textstyle"))
 (setq txh(getvar "textsize"))

(command "._undo" "BE")
 (setvar "osmode" 0)
 (setvar "textsize" 50.0)
 (while (setq ent (entsel "\nSelect pipe-line (or hit Enter to Exit): "))
   (if
     (member (strcase (cdr (assoc 0 (entget (car ent)))))
      (list "LWPOLYLINE" "SPLINE"))
      (progn
 (setq en (car ent))
 (setq curve (vlax-ename->vla-object en))
 (setq pt (vlax-curve-getclosestpointto en (cadr ent)))
 (setq leng (vlax-curve-getdistatparam en (vlax-curve-getendparam en)))
 (run-dialog leng )
 (if (not (setq dcl_id (load_dialog fn)))
   (exit))
 (if (not (new_dialog "water" dcl_id))
   (exit))
 (start_list "math")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq math_list
   (list "AB" "CD" "EF" "GH"))))
 (end_list)
 (start_list "dia")
 (mapcar 'add_list
  (mapcar 'vl-princ-to-string
   (setq dia_list
   (list 100 200 300 400 500))))
 (end_list)
 (action_tile
   "accept"
   (strcat "(progn "
    "(setq str_val (get_tile \"street\"))"
    "(setq leng_val (get_tile \"leng\"))"
    "(setq math_val (atoi (get_tile \"math\")))"
    "(setq dia_val (atoi (get_tile \"dia\")))"
    "(done_dialog 1))")
   )
 (action_tile "cancel" "(done_dialog 0)")
 (setq pick (start_dialog))
 (unload_dialog dcl_id)
 (vl-file-delete fn)
 (if (and (= 1 pick) str_val leng_val math_val dia_val)
   (progn
        (setq fst (vl-princ-to-string str_val))
        (setq snd (rtos (atof leng_val)2 3))
        (setq mat (vl-princ-to-string (setq mat_val (nth math_val math_list))))
        (setq dia(vl-princ-to-string (setq dia_val (nth dia_val dia_list))))

(setq  ang (angle
     '(0 0 0)
     (trans
       (vlax-curve-getfirstderiv
         curve
         (vlax-curve-getparamatpoint curve pt)
       )
       0 1 t 
     )
   )
)
(setq label
 (strcat
   "%<[url="file://\\AcObjProp"]\\AcObjProp[/url] Object(%<[url="file://\\_ObjId"]\\_ObjId[/url] "
   (itoa (vla-get-objectid curve))
   ">%).Length [url="file://\\f"]\\f[/url] \"%lu2%pr3\">%"
 )
 )
;;set text rotation angle to more readable:

(if (< (/ pi 2) ang (* pi 1.5))
 (setq ang (+ ang pi))
 )
(setq upt (polar pt (+ ang (/ pi 2)) (* (getvar "textsize") 1.5)))
(setq lpt (polar pt (- ang (/ pi 2)) (* (getvar "textsize") 1.5)))
(setq lpt1 (polar lpt (+ ang pi) (getvar "textsize")))
(setq lpt2 (polar lpt ang (getvar "textsize")))
(setq ang (rtd ang))

(setvar "cecolor" "bylayer")
(setvar "clayer" "1 Street")
(command "-mtext" "_non" upt "J" "MC" "H" 50.0 "R" ang "w" 0  fst "")      
(setvar "clayer" "2 Length")
(command "-mtext" "_non" pt "J" "MC" "H" 50.0 "R" ang "w" 0  label "")      
(setvar "clayer" "3 Mat")
  (command "-mtext" "_non" lpt1 "J" "MR" "H" 50.0 "R" ang "w" 0  mat "")   
(setvar "clayer" "4 Dia")
     (command "-mtext" "_non" lpt2 "J" "ML" "H" 50.0 "R" ang "w" 0  (strcat "%%c" dia) "")
   )
 )
     )
   )
   )
   (*error* nil)
 (princ)
 )
(princ "\n Start command with PPW")
(prin1)

Link to comment
Share on other sites

Hey, buddy

Do not force me to turn red,

I only the usual hacker

Though, you're welcome,

I'm glad if this routine will help with your work

 

~'J'~

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...