多边形线状提取lin
我试着发现lisp可以提取一个或多个多段线形状或边界形状，也许它是矩形的，在一张桌子上，我希望我能找到。 像这样的事情？(defun c:LW2tbL (/ hgt e insertionPoint tbl lengths selectionset integer selectionsetname)
(vl-load-com)
;;; Tharwat 06 . Nov . 2012 ;;;
(or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
(setq hgt (if (zerop (cdr (assoc 40 (setq e (entget (tblobjname "STYLE" (getvar 'textstyle)))))))
(* (getvar 'textsize) 2.0)
(cdr (assoc 40 e))
)
)
(if (setq lengths 0
selectionset
(ssget '((0 . "*POLYLINE")))
)
(repeat (setq integer (sslength selectionset))
(setq selectionsetname (ssname selectionset (setq integer (1- integer))))
(setq lengths (+ (vla-get-length (vlax-ename->vla-object selectionsetname)) lengths))
)
)
(if lengths
(progn (setq insertionPoint (getpoint "\n Specify Table Location :"))
(setq tbl (vla-addtable (vla-get-modelspace acdoc) (vlax-3d-point insertionPoint) 2 1 (* hgt 2.5) (* hgt 2.5)))
(vla-setcolumnwidth tbl 0 (* hgt 10.))
(vla-setrowheight tbl 0 (* hgt 1.5))
(vla-settext tbl 0 0 "\\C140;Total Lengths")
(vla-settext tbl 1 0 (rtos lengths 2))
(vla-setcellalignment tbl 1 0 acMiddleCenter)
(vla-setrowheight tbl 1 (* hgt 1.5))
)
)
(princ "\nWritten by Tharwat Al Shoufi")
(princ)
)
非常感谢tharwat先生，但如果我能为每个形状内容2个长度的单元格。
再次感谢
不客气。
你所说的每个形状内容是什么意思？
您可以发布表的快照吗？ 亲爱的塔瓦特先生，感谢您的支持。
我的意思是*每个形状的内容*根据附件，我需要为一个单元格上的形状提取单独的长度。 这里它适用于闭合多段线，其中一个字符串表示每个多段线的引用。。
(defun c:LW2Table (/ *error* lengths_Widths_Strings WriteAndSet e hgt i p lst r ss tbl) (vl-load-com)
;; Author : Tharwat Al Shoufi . Date: 07. Nov. 2012 ;;;
;; Sample of strings to be inserted into Table ;;;
;; (("S1" 3.48952 4.81861) ("S2" 3.48952 3.70302) ;;;
(defun *error (x) (princ "\n....") (princ "\n *Cancel*"))
(or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object))))
(setq hgt (if (zerop (cdr (assoc 40 (setq e (entget (tblobjname "STYLE" (getvar 'textstyle)))))))
(* (getvar 'textsize) 2.0)
(cdr (assoc 40 e))
)
)
(defun lengths_Widths_Strings (sn / pts l w ss)
(mapcar '(lambda (x)
(if (eq (car x) 10)
(setq pts (cons (list (cadr x) (caddr x)) pts))
)
)
(entget sn)
)
(setq l (distance (nth 0 pts) (nth 1 pts)))
(setq w (distance (nth 1 pts) (nth 2 pts)))
(if (setq ss (ssget "_wp" pts '((0 . "*TEXT"))))
(setq lst (cons (list (cdr (assoc 1 (entget (ssname ss 0)))) l w) lst))
)
(setq ss nil)
lst
)
(defun WriteAndSet (table col row string hgt wid)
(vla-settext table row col string)
(vla-setcellalignment table row col acMiddleCenter)
(vla-setrowheight table row (* hgt 1.5))
(vla-setcolumnwidth table col wid)
)
(if (setq ss (ssget '((0 . "*POLYLINE") (-4 . "&=") (70 . 1))))
(repeat (setq i (sslength ss)) (lengths_Widths_Strings (ssname ss (setq i (1- i)))))
)
(if lst
(progn (setq p (getpoint "\n Specify Table Location :"))
(setq tbl (vla-addtable
(vla-get-modelspace acdoc)
(vlax-3d-point p)
(1+ (length lst))
3
(* hgt 2.5)
(* hgt 2.5)
)
)
(vla-setcolumnwidth tbl 0 (* hgt 10.))
(vla-setrowheight tbl 0 (* hgt 1.5))
(vla-settext tbl 0 0 "\\C140;Total Lengths")
(setq r 0)
(setq lst (vl-sort lst '(lambda (a b) (< (atof (substr (car a) 2)) (atof (substr (car b) 2))))))
(foreach x lst
(WriteAndSet tbl 0 (setq r (1+ r)) (car x) hgt (* (* hgt 10.) 0.2))
(WriteAndSet tbl 1 r (rtos (cadr x) 2) hgt (* (* hgt 10.) 0.4))
(WriteAndSet tbl 2 r (rtos (caddr x) 2) hgt (* (* hgt 10.) 0.4))
)
)
)
(princ "\nWritten by Tharwat Al Shoufi")
(princ)
)
亲爱的Tharwat先生，非常感谢，非常好。
但是我还有一件事，我希望我们可以在lisp上完成，根据附件，我们可以找到不规则形状，如果可能的话，在不规则的名称上放一个类似星号的符号，并计算每个名称。
再次感谢tharwat先生 您已经三次改变您的观点，很抱歉，由于无法正确确定长度和宽度，最后一个附加图像中的多段线不包括在内。 再一次，我想说对不起，但正如你们所知道的，当你们第一次思考一个想法时，并不像第二次那样，你们已经达到了这个想法，你们知道我们的领域在不停地改进。
我希望你可以添加条件来捕捉非法形状。
谢谢 http://www.cadtutor.net/forum/showthread.php?12536-文本或块计数
请允许我用这个Lisp程序为形状名称添加计数器。
页:
[1]
2