(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)
; same with this
(setq curspace (vla-get-modelspace doc))
我做了更改，但不起作用？
; dwg index to a table
; by Alan H NOV 2013
(defun AH:dwgindex (/ doc objtable ss1 lay ans ans2 plotabs ss1 tag2 tag3 list1 list2 curlayout colwidth numcolumns numrows INC rowheight )
(vl-load-com)
(setq curlayout (getvar "ctab"))
(if (= curlayout "Model")
(progn
(princ) ; dummy for else
(Alert "You need to be in model space for this option")
(exit)
) ; end progn
) ; end if model
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
; same with this
(setq curspace (vla-get-modelspace doc))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:")))
;(setq pt1 (vlax-3d-point '(0 0 0)))
; for testing
; read values from title blocks
;(setq bname "DA1DRTXT")
(setq bname "COGG_TITLE")
(setq tag2 "DRG_NO") ;attribute tag name
(setq tag3 "WORKS_DESCRIPTION") ;attribute tag name
(setq ss1 (ssget "x"(list (cons 0 "INSERT") (cons 2 bname))))
(setq INC (sslength ss1))
(repeat INC
(foreach att (vlax-invoke (vlax-ename->vla-object (ssname SS1 (SETQ INC (- INC 1)) )) 'getattributes)
(if (= tag2 (strcase (vla-get-tagstring att)))
(progn
(setq ans (vla-get-textstring att))
(if (/= ans NIL)
(setq list1 (cons ans list1))
) ; if
); end progn
) ; end if
(if (= tag3 (strcase (vla-get-tagstring att)))
(progn
(setq ans2 (vla-get-textstring att))
(if (/= ans2 NIL)
(setq list2 (cons ans2 list2))
) ; end if
) ; end progn
) ; end if tag3
) ; end foreach
) ; end repeat
(setvar 'ctab curlayout)
(command "Zoom" "E")
(command "regen")
(reverse list1)
;(reverse list2)
; now do table
(setq numrows (+ 2 (sslength ss1)))
(setq numcolumns 2)
(setq rowheight 0.2)
(setq colwidth 130)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "DRAWING REGISTER")
(vla-settext objtable 1 0 "DRAWING NUMBER")
(vla-settext objtable 1 1 "DRAWING TITLE")
(SETQ X 0)
(SETQ Y 2)
(REPEAT (sslength ss1)
(vla-settext objtable Y 0 (NTH X LIST1))
(vla-settext objtable Y 1 (NTH X LIST2))
(vla-setrowheight objtable y 10)
(SETQ X (+ X 1))
(SETQ Y (+ Y 1))
)
(vla-setcolumnwidth objtable 0 55)
(vla-setcolumnwidth objtable 1 130)
(command "_zoom" "e")
); end AH defun
(AH:dwgindex)
(princ) 我发布的例子只是展示了如何做一些事情的方法，比如你想要什么，而不是对你的请求的一个精确的解决方案——代码必须更改。
CADTUTOR不是一个免费的网站，任何人都可以访问并获得一个专门编写的soloution。如果我能抽出时间，我会更改代码。
你已经贴了很多次了，所以现在可能是你开始尝试写一些Lisp程序的东西的时候了。这里有很多人可以帮助并且非常愿意帮助那些自助的人。 为了好玩
(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc cnt datap1 p2 p1l p2l p3 ip data num)
(vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
(defun _AttFunc(en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
(if (and lst (setq v (assoc (car vals) lst)))
(vla-put-textstring at (cadr v))) vals))
(vlax-invoke (if (eq (type en) 'VLA-OBJECT)
en (vlax-ename->vla-object en)) 'Getattributes)
)
)
(if (not (member "geomcal.arx" (arx)))
(arxload "geomcal")
)
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace ADoc)
(vla-get-ModelSpace ADoc)
))
(setq cnt -1 num 0)
(if (and (vl-every '(lambda (b)
(setq cnt (1+ cnt))
(tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(setq p1 (getpoint "\nPick Base Referene point: "))
(setq p2 (getpoint p1 "\nPick Second point: "))
(setq p1l (getstring "\nEnter Label of BP: "))
(setq p2l (getstring "\nEnter Label of SP: "))
)
(progn
(setq angs (If (> (car p1)(car p2))
"ang(p1,p3,p2)" "ang(p1,p2,p3)"))
(setqdata nil)
(vlax-invoke space 'AddLine p1 p2)
(_AttFunc (_Insert space "STATION" p1 ) (list (list "POINT" (strcase p1l))));<-- Optional
(_AttFunc (_Insert space "STATION" p2 ) (list (list "POINT" (strcase p2l))));<-- Optional
(while (setq p3 (getpoint p1 (strcat "\nPick point " (itoa (setq num (1+ num)))":")))
;;; Place here DimeAng line <Optional> ;;;
;;; ;;;
(entmakex (list (cons 0 "LINE")'(6 . "HIDDEN2")'(8 . "Distance")
(cons 10 p1) (cons 11 p3)))
(_AttFunc (_Insert space "POINT" p3 ) (list (list "POINT" (itoa num))))
(setq data (cons (list
(itoa num)
(Strcat
(rtos
(cvunit (c:cal angs)
"degree" "grad") 2 4)
"g"
)
(rtos (distance p1 p3) 2 2)
) data))
)
(setq ip (getpoint"\nPick Base point for Table: "))
(_AttFunc (_Insert space "TITLE" ip )
(list (list "TITLE" (strcat "FROM " (strcase p1l) " -> " (strcase p2l)))))
(foreach itm (reverse data)
(_AttFunc (_Insert space "DATA" ip )
(list (list "NUM" (car itm))
(list "BEARING" (cadr itm))
(list "DISTANCE" (last itm))))
(setq ip (polar ip (* pi 1.5) 1.0)))
)
(princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
)
(princ)
)
你好，谢谢你的代码，但如果可以的话，我还需要一些修改
1） 我想要DiaTabs。当我“为表格拾取基点：”
2） 用同样的方法我“选择基准参考点：”并选择块并写入块的文本，用同样的方法当我选择文本块时写入文本的名称。因为在某些情况下，项目编号的顺序不是（1、2、3、4、5……100等），而是随机的（50、48、32、60、72、34、15.22……等）
DiaTabs。图纸 我试过这个，但我有一个小错误。。。。
我仍然有这个问题
2） 用同样的方法我“选择基准参考点：”并选择块并写入块的文本，用同样的方法当我选择文本块时写入文本的名称。因为在某些情况下，项目编号的顺序不是（1、2、3、4、5……100等），而是随机的（50、48、32、60、72、34、15.22……等）
(Defun c:DiaTabs ;|<--- haha |; ( / _Insert _AttFunc _getprop cnt data space ob1 ob2 ob3p1 p2 p3 ipnum)
(vl-load-com)
(defun _insert (sp bname p)(vlax-invoke space 'InsertBlock p bname 1 1 1 0))
(defun _AttFunc(en lst / vals v)
(mapcar (function (lambda (at)
(setq vals (list (vla-get-tagstring at)(vla-get-textstring at)))
(if (and lst (setq v (assoc (car vals) lst)))
(vla-put-textstring at (cadr v))) vals))
(vlax-invoke (if (eq (type en) 'VLA-OBJECT)
en (vlax-ename->vla-object en)) 'Getattributes)
)
)
(defun _getprop (msg bn tg )
(prompt msg)
(if (setq
s (ssget "_:S:L" (list '(0 . "INSERT") '(66 . 1) (cons 2 bn)))
)
(setq att (_AttFunc (ssname s 0) nil)
ip (cdr (assoc 10 (entget (ssname s 0)))))
(progn (princ "\n<<Invlaid Seletion>>") (_getprop msg bn tg))
)
(list ip (assoc tg att) )
)(if (not (member "geomcal.arx" (arx)))
(arxload "geomcal")
)
(setq ADoc (vla-get-activedocument (vlax-get-acad-object))
Space (if (= (getvar "CVPORT") 1)
(vla-get-PaperSpace ADoc)
(vla-get-ModelSpace ADoc)
))
(setq cnt -1 num 1)
(if (vl-every '(lambda (b)
(setq cnt (1+ cnt))
(tblsearch "BLOCK" b)) (setq blks '("STATION" "POINT" "TITLE" "DATA")))
(progn
(setq ob1 (_GETPROP "\nPick Base Referene point: " "STATION" "POINT" ))
(setq ob2 (_GETPROP "\nPick Second point: " "STATION" "POINT" ))
(setq p1 (Car ob1) p2 (car ob2))
(setq angs (If (> (car p1)(car p2))
"ang(p1,p3,p2)" "ang(p1,p2,p3)"))
(setqdata nil)
(while(setq p3 (getpoint p1 (strcat "\nPick point " (itoa num)":")))
(if (and (cadr (sssetfirst nil(ssget"_C" p3 p3 '((2 . "POINT")))))
(setq ob3 (_GETPROP (strcat "\nPick point " (itoa num)":")
"POINT" "POINT" )))
(progn (setq p3 (car ob3))
(setq data (cons (list
(itoa num)
(Strcat
(rtos
(cvunit (c:cal angs)
"degree" "grad") 2 4)
"g"
)
(rtos (distance p1 p3) 2 2)
) data))
(setq num (1+ num))
)
(princ "\nBlock \"POINT\" Not found"))
)
(setq ip (getpoint"\nPick Base point for Table: "))
(_AttFunc (_Insert space "TITLE" ip )
(list (list "TITLE" (strcat "FROM " (strcase (cadadr ob1)) " -> " (strcase (cadadr ob2))))))
(foreach itm (reverse data)
(_AttFunc (_Insert space "DATA" ip )
(list (list "NUM" (car itm))
(list "BEARING" (cadr itm))
(list "DISTANCE" (last itm))))
(setq ip (polar ip (* pi 1.5) 1.0)))
)
(princ (strcat "\n<<<Block " (nth cnt blks) " Not Found>>>"))
)
(princ)
)
DiaTabs。图纸 有什么想法吗？
想法，很多！！
时间不多。
耐心[迅速耗尽…]
[参考帖子#13]
Ideas, a lot!!
Time, not so much.
Patience
页:
1
[2]