[编程交流] 钢筋去鳞

(vl-load-com)
(defun c:mult-info_po2cell ( / js obj ename n AcDoc Space pr nb lst_id-seg lst_pt lst_length lst_alpha lst_rad id all_path j end_pos id_path fonts_path file_shx
                              nw_obj nw_style dist_start dist_end pt_start pt_end seg_len seg_bulge rad alpha oldim oldlay h_t w_c ename_cell n_row n_column)
   (princ "\nSelect polylines.")
   (while (null (setq js (ssget '((0 . "LWPOLYLINE")))))
       (princ "\nSelection empty, or is not a available polyline!")
   )
   (setq
       AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
       Space
       (if (= 1 (getvar "CVPORT"))
           (vla-get-PaperSpace AcDoc)
           (vla-get-ModelSpace AcDoc)
       )
   )
   (cond
       ((null (tblsearch "LAYER" "Table-Polyline"))
           (vla-add (vla-get-layers AcDoc) "Table-Polyline")
       )
   )
   (cond
       ((null (tblsearch "STYLE" "Text-Cell"))
           (setq all_path (getenv "ACAD") j 0)
           (while (setq end_pos (vl-string-position (ascii ";") all_path))
               (setq id_path (substr all_path 1 end_pos))
               (if (wcmatch (strcase id_path) "*FONTS*")
                   (setq fonts_path (strcat id_path "\"))
               )
               (setq all_path (substr all_path (+ 2 end_pos)))
           )
           (setq file_shx (getfiled "Select a font file " fonts_path "shx" )
           (if (not file_shx)
               (setq file_shx "txt.shx")
           )
           (setq nw_style (vla-add (vla-get-textstyles AcDoc) "Text-Cell"))
           (mapcar
               '(lambda (pr val)
                   (vlax-put nw_style pr val)
               )
               (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag)
               (list file_shx 0.0 (/ (* 15.0 pi) 180) 1.0 0.0)
           )
           (command "_.ddunits"
               (while (not (zerop (getvar "cmdactive")))
                   (command pause)
               )
           )
       )
   )
   (setq
       oldim (getvar "dimzin")
       oldlay (getvar "clayer")
   )
   (setvar "dimzin" 0) (setvar "clayer" "Table-Polyline")
   (initget 9)
   (setq ins_pt_cell (getpoint "\nLeft-Up insert point of table: "))
   (initget 6)
   (setq h_t (getdist ins_pt_cell (strcat "\nHigth text <" (rtos (getvar "textsize")) ">: ")))
   (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t))
   (initget 7)
   (setq w_c (getdist ins_pt_cell "\nWidth of cells: "))
   (setq
       lst_id-seg '()
       lst_pt '()
       lst_length '()
       lst_alpha '()
       lst_rad '()
       nb 0
       id 0
   )
   (repeat (setq n (sslength js))
       (setq
           obj (ssname js (setq n (1- n)))
           ename (vlax-ename->vla-object obj)
           pr -1
           id (1+ id)
       )
       (repeat (fix (vlax-curve-getEndParam ename))
           (setq
               dist_start (vlax-curve-GetDistAtParam ename (setq pr (1+ pr)))
               dist_end (vlax-curve-GetDistAtParam ename (1+ pr))
               pt_start (vlax-curve-GetPointAtParam ename pr)
               pt_end (vlax-curve-GetPointAtParam ename (1+ pr))
               seg_len (- dist_end dist_start)
               seg_bulge (vla-GetBulge ename pr)
               rad (if (zerop seg_bulge) 0.0 (/ seg_len (* 4.0 (atan seg_bulge))))
               alpha (if (zerop seg_bulge) (angle pt_start pt_end) 0.0)
               lst_id-seg (cons (strcat "P" (itoa id) "-" (itoa nb)) lst_id-seg)
               lst_pt (cons pt_start lst_pt)
               lst_length (cons seg_len lst_length)
               lst_rad (cons (abs rad) lst_rad)
               lst_alpha (cons alpha lst_alpha)
               nb (1+ nb)
           )
       )
       (if (eq (vla-get-closed ename) :vlax-false)
           (setq lst_id-seg (cons (strcat "P" (itoa id) "-" (itoa nb)) lst_id-seg))
           (setq lst_id-seg (cons (strcat "P" (itoa id) "-" (itoa (- nb (fix (vlax-curve-getEndParam ename))))) lst_id-seg))
       )
       (setq
           lst_pt (cons pt_end lst_pt)
           lst_length (cons 0.0 lst_length) lst_rad (cons 0.0 lst_rad) lst_alpha (cons 0.0 lst_alpha)
           nb (1+ nb)
       )
   )
   (mapcar
       '(lambda (p tx)
           (setq nw_obj
               (vla-addMtext Space
                   (vlax-3d-point p)
                   0.0
                   tx
               )
           )
           (mapcar
               '(lambda (pr val)
                   (vlax-put nw_obj pr val)
               )
               (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation)
               (list 5 h_t 5 p "Text-Cell" "Table-Polyline" 0.0)
           )
       )
       lst_pt
       lst_id-seg
   )
   (vla-addTable Space (vlax-3d-point ins_pt_cell) (+ 2 nb) 6 (+ h_t (* h_t 0.25)) w_c)
   (setq ename_cell (vlax-ename->vla-object (entlast)) n_row (1+ nb) n_column -1)
   (vla-SetCellValue ename_cell 0 0
       (vlax-make-variant
           (strcat "Summary of " (itoa (sslength js)) " LWPOLYLINES")
           8
       )
   )
   (vla-SetCellTextStyle ename_cell 0 0 "Text-Cell")
   (vla-SetCellTextHeight ename_cell 0 0 (vlax-make-variant h_t 5))
   (vla-SetCellAlignment ename_cell 0 0 5)
   (foreach n
       (mapcar'list
           (append lst_id-seg '("N°"))
           (append (mapcar 'rtos (mapcar 'car lst_pt)) '("Coordinates X"))
           (append (mapcar 'rtos (mapcar 'cadr lst_pt)) '("Coordinates Y"))
           (append (mapcar 'rtos lst_length) '("Lengths"))
           (append (mapcar 'angtos lst_alpha) '("Directions"))
           (append (mapcar 'rtos lst_rad) '("Radius"))
       )
       (mapcar
           '(lambda (el)
               (vla-SetCellValue ename_cell n_row (setq n_column (1+ n_column))
                   (if (or (eq (rtos 0.0) el) (eq (angtos 0.0) el)) (vlax-make-variant "_"  (vlax-make-variant el )
               )
               (vla-SetCellTextStyle ename_cell n_row n_column "Text-Cell")
               (vla-SetCellTextHeight ename_cell n_row n_column (vlax-make-variant h_t 5))
               (if (eq n_row 1)
                   (vla-SetCellAlignment ename_cell n_row n_column 5)
                   (vla-SetCellAlignment ename_cell n_row n_column 6)
               )
           )
           n
       )
       (setq n_row (1- n_row) n_column -1)
   )
   (setvar "dimzin" oldim) (setvar "clayer" oldlay)
   (prin1)
)