[编程交流] 带文字的自定义多段线

;; 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)

;; 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)

(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)
 )