带文字的自定义多段线
是否可以创建自定义多段线以将信息附加到其中，如“pipe size”“lenth”“HWS”“HWR”。我想做的是画一个管道，电线或单线管道布局与上面的普林线信息！甚至编辑信息。最好是画一条线，然后返回并选择一条线，信息将被放置在该线上，或者选择有引线的信息！
谁能帮帮我！
正如我所建议的，你们能在这里张贴一张修改前后的图纸吗？我的图纸很容易理解。
注意：更改了线程标题，使其更具描述性 我不久前为一个人写的
来自讨论。团体论坛
这里有两个Lisp程序的地方，只是稍微修改一下你的西装，
第一个将向选定管道添加扩展数据，
第二个将绘制表格并填充
它们具有扩展数据
;; 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-setgridlineweighttblstyle 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)
(setqrow 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'~ 谢谢你的代码。
这是你写的代码，它将与什么版本的cad一起工作！
我正在使用autoCAD 2004，当我加载代码并在xar中键入时，我得到的选定pline或line是错误的！
; 错误：错误的DXF组：（-3（“PIPEINFO”（1040.3.0）（1041）（1000）”）（1000。
“HWR”））
键入art并出现此错误。
; 错误：ActiveX服务器返回错误：未知名称：“AddTable” 我不确定，但我认为
AcadTable对象嵌入到
AutoCAD仅从A2006版本开始
你需要画一张普通的桌子
使用线条
我有类似的程序可以做到这一点
但我需要时间把它们改写成这样
适合
也许明天我有空做这项工作
后来
~'J'~ 好的，我必须为你的版本重写它
试试这个
;; 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 10p0)
(cons 11 (list (+ x wid) y))))
(setq y (- ytitle_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 10p0)
(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'~ 非常有趣和有用的lisp。
我有兴趣使用DCL输入数据（见图纸）。
我用的是Acad2008。
顺致敬意，
供水网络。图纸 上述问题没有解决方案？
祝你一切顺利 这会让你开始工作，自己休息
我没有时间做这项工作
(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)
)
页:
[1]
2