[编程交流] 多边形线状提取lin

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

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