Author Topic: 2d and 3d polyline information ??  (Read 921 times)

0 Members and 1 Guest are viewing this topic.

pedroantonio

  • Guest
2d and 3d polyline information ??
« on: January 12, 2018, 03:42:30 AM »
Hi . I am using Lee Mac code for 2d polylines. Is it possible to work with 3d plylies and export a table with

point number , coord x, coord y , coord z , distance , slope

Code - Auto/Visual Lisp: [Select]
  1. ;;---------------------=={ Polyline Information }==---------------------;;
  2. ;;                                                                      ;;
  3. ;;  This program provides the user with detailed information about      ;;
  4. ;;  every segment of a selected polyline in the form of either an       ;;
  5. ;;  AutoCAD Table (if available), Text file, or CSV file.               ;;
  6. ;;                                                                      ;;
  7. ;;  Upon calling the program with the command syntax 'polyinfo' at the  ;;
  8. ;;  AutoCAD command-line, the user is prompted to select an LWPolyline  ;;
  9. ;;  to be queried from the active drawing. At this prompt the user      ;;
  10. ;;  also has the option to choose the form of output for the            ;;
  11. ;;  information harvested by the program; this output format will be    ;;
  12. ;;  remembered between drawing sessions to enable streamlined repeated  ;;
  13. ;;  program usage.                                                      ;;
  14. ;;                                                                      ;;
  15. ;;  The program will output LWPolyline segment data to either an        ;;
  16. ;;  AutoCAD Table Object created in the active drawing (if such object  ;;
  17. ;;  is available in the version of AutoCAD in which the program is      ;;
  18. ;;  being executed), or a tab-delimited Text file or CSV file           ;;
  19. ;;  automatically created (streamlining the program to minimise         ;;
  20. ;;  prompts) in the working directory of the active drawing.            ;;
  21. ;;                                                                      ;;
  22. ;;  For every segment of the selected LWPolyline, the program will      ;;
  23. ;;  extract the following information:                                  ;;
  24. ;;                                                                      ;;
  25. ;;      • Segment Number                                                ;;
  26. ;;      • Segment Start Vertex Coordinate                               ;;
  27. ;;      • Segment End Vertex Coordinate                                 ;;
  28. ;;      • Segment Start Width                                           ;;
  29. ;;      • Segment End Width                                             ;;
  30. ;;      • Segment Length                                                ;;
  31. ;;      • Arc Centre (if arc segment)                                   ;;
  32. ;;      • Arc Radius (if arc segment)                                   ;;
  33. ;;                                                                      ;;
  34. ;;----------------------------------------------------------------------;;
  35. ;;  Author:  Lee Mac, Copyright 2014  -  www.lee-mac.com              ;;
  36. ;;----------------------------------------------------------------------;;
  37. ;;  Version 1.0    -    2012-07-10                                      ;;
  38. ;;                                                                      ;;
  39. ;;  - First release.                                                    ;;
  40. ;;----------------------------------------------------------------------;;
  41. ;;  Version 1.1    -    2012-07-16                                      ;;
  42. ;;                                                                      ;;
  43. ;;  - Added Table & Text file output options.                           ;;
  44. ;;  - Removed basic LWPolyline properties.                              ;;
  45. ;;----------------------------------------------------------------------;;
  46. ;;  Version 1.2    -    2014-06-14                                      ;;
  47. ;;                                                                      ;;
  48. ;;  - Fixed bug causing final segment to be omitted from output data    ;;
  49. ;;    when processing closed polylines.                                 ;;
  50. ;;----------------------------------------------------------------------;;
  51. ;;  Version 1.3    -    2015-04-13                                      ;;
  52. ;;                                                                      ;;
  53. ;;  - Fixed bug causing the program to crash when processing polylines  ;;
  54. ;;    containing arc segments.                                          ;;
  55. ;;----------------------------------------------------------------------;;
  56.  
  57. (defun c:polyinfo ( / *error* ent enx flg ins lst out seg tmp )
  58.  
  59.     (defun *error* ( msg )
  60.         (LM:endundo (LM:acdoc))
  61.         (if (= 'str (type out)) (setenv "LMac\\PolyInfo" out))
  62.         (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  63.             (princ (strcat "\nError: " msg))
  64.         )
  65.         (princ)
  66.     )
  67.    
  68.     (if (null (setq out (getenv "LMac\\PolyInfo")))
  69.         (setq out "TXT")
  70.     )
  71.     (princ
  72.         (strcat "\nOutput Format: "
  73.             (cond
  74.                 (   (= out "TXT") "Text File")
  75.                 (   (= out "CSV") "CSV File")
  76.                 (   "AutoCAD Table"   )
  77.             )
  78.         )
  79.     )
  80.  
  81.     (while
  82.         (progn
  83.             (setvar 'errno 0)
  84.             (initget "Output")
  85.             (setq ent (entsel "\nSelect polyline [Output]: "))
  86.             (cond
  87.                 (   (= 7 (getvar 'errno))
  88.                     (princ "\nMissed, try again.")
  89.                 )
  90.                 (   (null ent)
  91.                     nil
  92.                 )
  93.                 (   (= "Output" ent)
  94.                     (polyinfo:chooseoutput  'out)
  95.                     (setenv "LMac\\PolyInfo" out)
  96.                     (princ
  97.                         (strcat "\nOutput Format: "
  98.                             (cond
  99.                                 (   (= out "TXT") "Text File")
  100.                                 (   (= out "CSV") "CSV File")
  101.                                 (   "AutoCAD Table"   )
  102.                             )
  103.                         )
  104.                     )
  105.                 )
  106.                 (   (/= "LWPOLYLINE" (cdr (assoc 0 (entget (setq ent (car ent))))))
  107.                     (princ "\nSelected object is not an LWPolyline.")
  108.                 )
  109.             )
  110.         )
  111.     )
  112.     (cond
  113.         (   (and
  114.                 (= 'ename (type ent))
  115.                 (= "Table" out)
  116.                 (= 4 (logand 4 (cdr (assoc 70 (tblsearch "layer" (getvar 'clayer))))))
  117.             )
  118.             (princ "\nCurrent layer locked.")
  119.         )
  120.         (   (= 'ename (type ent))
  121.             (setq seg 0
  122.                   enx (entget ent)
  123.                   lst (LM:lwvertices enx)
  124.                   lst
  125.                 (cons
  126.                     (append '("SEG." "START X" "START Y" "END X" "END Y" "WIDTH 1" "WIDTH 2" "LENGTH")
  127.                         (if (setq flg (vl-some '(lambda ( x ) (not (zerop (cdr (assoc 42 x))))) lst))
  128.                            '("CENTRE X" "CENTRE Y" "RADIUS")
  129.                         )
  130.                     )
  131.                     (mapcar
  132.                         (function
  133.                             (lambda ( l1 l2 / b p q )
  134.                                 (setq p (cdr (assoc 10 l1))
  135.                                       q (cdr (assoc 10 l2))
  136.                                       b (cdr (assoc 42 l1))
  137.                                 )
  138.                                 (append
  139.                                     (list (itoa (setq seg (1+ seg))))
  140.                                     (mapcar 'rtos p)
  141.                                     (mapcar 'rtos q)
  142.                                     (list
  143.                                         (rtos (cdr (assoc 40 l1)))
  144.                                         (rtos (cdr (assoc 41 l1)))
  145.                                     )
  146.                                     (if (zerop b)
  147.                                         (cons (rtos (distance p q)) (if flg '("" "" "")))
  148.                                         (append
  149.                                             (list (rtos (abs (* (LM:bulgeradius p q b) (atan b) 4))))
  150.                                             (mapcar 'rtos (LM:bulgecentre p q b))
  151.                                             (list (rtos (LM:bulgeradius p q b)))
  152.                                         )
  153.                                     )
  154.                                 )
  155.                             )
  156.                         )
  157.                         lst
  158.                         (if (= 1 (logand 1 (cdr (assoc 70 enx))))
  159.                             (append (cdr lst) (list (car lst)))
  160.                             (cdr lst)
  161.                         )
  162.                     )
  163.                 )
  164.             )
  165.             (cond
  166.                 (   (= out "TXT")
  167.                     (if (LM:writetxt lst (setq tmp (vl-filename-mktemp (cdr (assoc 5 enx)) (getvar 'dwgprefix) ".txt")))
  168.                         (startapp "explorer" tmp)
  169.                     )
  170.                 )
  171.                 (   (= out "CSV")
  172.                     (if (LM:writecsv lst (setq tmp (vl-filename-mktemp (cdr (assoc 5 enx)) (getvar 'dwgprefix) ".csv")))
  173.                         (startapp "explorer" tmp)
  174.                     )
  175.                 )
  176.                 (   (setq ins (getpoint "\nSpecify point for table: "))
  177.                     (LM:startundo (LM:acdoc))
  178.                     (LM:addtable  (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)) (trans ins 1 0) nil lst nil)
  179.                     (LM:endundo   (LM:acdoc))
  180.                 )
  181.             )
  182.         )
  183.     )
  184.     (princ)
  185. )
  186.  
  187. ;; Add Table  -  Lee Mac
  188. ;; Generates a table at the given point, populated with the given data and optional title.
  189. ;; spc - [vla] VLA Block object
  190. ;; ins - [lst] WCS insertion point for table
  191. ;; ttl - [str] [Optional] Table title
  192. ;; lst - [lst] Matrix list of table cell data
  193. ;; eqc - [bol] If T, columns are of equal width
  194. ;; Returns: [vla] VLA Table Object
  195.  
  196. (defun LM:addtable ( spc ins ttl lst eqc / dif hgt i j obj stn sty wid )
  197.     (setq sty
  198.         (vlax-ename->vla-object
  199.             (cdr
  200.                 (assoc -1
  201.                     (dictsearch (cdr (assoc -1 (dictsearch (namedobjdict) "acad_tablestyle")))
  202.                         (getvar 'ctablestyle)
  203.                     )
  204.                 )
  205.             )
  206.         )
  207.     )
  208.     (setq hgt (vla-gettextheight sty acdatarow))
  209.     (if (LM:annotative-p (setq stn (vla-gettextstyle sty acdatarow)))
  210.         (setq hgt (/ hgt (cond ((getvar 'cannoscalevalue)) (1.0))))
  211.     )
  212.     (setq wid
  213.         (mapcar
  214.            '(lambda ( col )
  215.                 (apply 'max
  216.                     (mapcar
  217.                        '(lambda ( str )
  218.                             (   (lambda ( box ) (if box (+ (* 2.5 hgt) (- (caadr box) (caar box))) 0.0))
  219.                                 (textbox
  220.                                     (list
  221.                                         (cons 01 str)
  222.                                         (cons 40 hgt)
  223.                                         (cons 07 stn)
  224.                                     )
  225.                                 )
  226.                             )
  227.                         )
  228.                         col
  229.                     )
  230.                 )
  231.             )
  232.             (apply 'mapcar (cons 'list lst))
  233.         )
  234.     )
  235.     (if
  236.         (and ttl
  237.             (< 0.0
  238.                 (setq dif
  239.                     (/
  240.                         (-
  241.                             (   (lambda ( box ) (if box (+ (* 2.5 hgt) (- (caadr box) (caar box))) 0.0))
  242.                                 (textbox
  243.                                     (list
  244.                                         (cons 01 ttl)
  245.                                         (cons 40 hgt)
  246.                                         (cons 07 stn)
  247.                                     )
  248.                                 )
  249.                             )
  250.                             (apply '+ wid)
  251.                         )
  252.                         (length wid)
  253.                     )
  254.                 )
  255.             )
  256.         )
  257.         (setq wid (mapcar '(lambda ( x ) (+ x dif)) wid))
  258.     )
  259.     (setq obj
  260.         (vla-addtable spc
  261.             (vlax-3D-point ins)
  262.             (1+ (length lst))
  263.             (length (car lst))
  264.             (* 2.0 hgt)
  265.             (if eqc
  266.                 (apply 'max wid)
  267.                 (/ (apply '+ wid) (float (length (car lst))))
  268.             )
  269.         )
  270.     )
  271.     (vla-put-regeneratetablesuppressed obj :vlax-true)
  272.     (vla-put-stylename obj (getvar 'ctablestyle))
  273.     (setq i -1)
  274.     (if (null eqc)
  275.         (foreach col wid
  276.             (vla-setcolumnwidth obj (setq i (1+ i)) col)
  277.         )
  278.     )
  279.     (if ttl
  280.         (progn
  281.             (vla-settext obj 0 0 ttl)
  282.             (setq i 1)
  283.         )
  284.         (progn
  285.             (vla-deleterows obj 0 1)
  286.             (setq i 0)
  287.         )
  288.     )
  289.     (foreach row lst
  290.         (setq j 0)
  291.         (foreach val row
  292.             (vla-settext obj i j val)
  293.             (setq j (1+ j))
  294.         )
  295.         (setq i (1+ i))
  296.     )
  297.     (vla-put-regeneratetablesuppressed obj :vlax-false)
  298.     obj
  299. )
  300.  
  301. ;; Write CSV  -  Lee Mac
  302. ;; Writes a matrix list of cell values to a CSV file.
  303. ;; lst - [lst] list of lists, sublist is row of cell values
  304. ;; csv - [str] filename of CSV file to write
  305. ;; Returns T if successful, else nil
  306.  
  307. (defun LM:writecsv ( lst csv / des sep )
  308.     (if (setq des (open csv "w"))
  309.         (progn
  310.             (setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
  311.             (foreach row lst (write-line (LM:lst->csv row sep) des))
  312.             (close des)
  313.             t
  314.         )
  315.     )
  316. )
  317.  
  318. ;; List -> CSV  -  Lee Mac
  319. ;; Concatenates a row of cell values to be written to a CSV file.
  320. ;; lst - [lst] list containing row of CSV cell values
  321. ;; sep - [str] CSV separator token
  322.  
  323. (defun LM:lst->csv ( lst sep )
  324.     (if (cdr lst)
  325.         (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
  326.         (LM:csv-addquotes (car lst) sep)
  327.     )
  328. )
  329.  
  330. (defun LM:csv-addquotes ( str sep / pos )
  331.     (cond
  332.         (   (wcmatch str (strcat "*[`" sep "\"]*"))
  333.             (setq pos 0)    
  334.             (while (setq pos (vl-string-position 34 str pos))
  335.                 (setq str (vl-string-subst "\"\"" "\"" str pos)
  336.                       pos (+ pos 2)
  337.                 )
  338.             )
  339.             (strcat "\"" str "\"")
  340.         )
  341.         (   str   )
  342.     )
  343. )
  344.  
  345. ;; Write Text File  -  Lee Mac
  346. ;; Writes a matrix of values to a tab-delimited Text file.
  347. ;; lst - [lst] list of lists, sublist is line of text values
  348. ;; txt - [str] filename of Text file to write
  349. ;; Returns T if successful, else nil
  350.  
  351. (defun LM:writetxt ( lst txt / des )
  352.     (if (setq des (open txt "w"))
  353.         (progn
  354.             (foreach itm lst (write-line (LM:lst->str itm "\t") des))
  355.             (close des)
  356.             t
  357.         )
  358.     )
  359. )
  360.  
  361. ;; List to String  -  Lee Mac
  362. ;; Concatenates each string in a supplied list, separated by a given delimiter
  363. ;; lst - [lst] List of strings to concatenate
  364. ;; del - [str] Delimiter string to separate each item
  365.  
  366. (defun LM:lst->str ( lst del )
  367.     (if (cdr lst)
  368.         (strcat (car lst) del (LM:lst->str (cdr lst) del))
  369.         (car lst)
  370.     )
  371. )
  372.  
  373. ;; Annotative-p  -  Lee Mac
  374. ;; Predicate function to determine whether a Text Style is annotative.
  375. ;; sty - [str] Name of Text Style
  376.  
  377. (defun LM:annotative-p ( sty )
  378.     (and (setq sty (tblobjname "style" sty))
  379.          (setq sty (cadr (assoc -3 (entget sty '("AcadAnnotative")))))
  380.          (= 1 (cdr (assoc 1070 (reverse sty))))
  381.     )
  382. )
  383.  
  384. ;; LW Vertices  -  Lee Mac
  385. ;; Returns a list of lists in which each sublist describes
  386. ;; the position, starting width, ending width and bulge of the
  387. ;; vertex of a supplied LWPolyline
  388.  
  389. (defun LM:lwvertices ( e )
  390.     (if (setq e (member (assoc 10 e) e))
  391.         (cons
  392.             (list
  393.                 (assoc 10 e)
  394.                 (assoc 40 e)
  395.                 (assoc 41 e)
  396.                 (assoc 42 e)
  397.             )
  398.             (LM:lwvertices (cdr e))
  399.         )
  400.     )
  401. )
  402.  
  403. ;; Bulge Radius  -  Lee Mac
  404. ;; p1 - start vertex
  405. ;; p2 - end vertex
  406. ;; b  - bulge
  407. ;; Returns the radius of the arc described by the given bulge and vertices
  408.  
  409. (defun LM:bulgeradius ( p1 p2 b )
  410.     (/ (* (distance p1 p2) (1+ (* b b))) 4 (abs b))
  411. )
  412.  
  413. ;; Bulge Centre  -  Lee Mac
  414. ;; p1 - start vertex
  415. ;; p2 - end vertex
  416. ;; b  - bulge
  417. ;; Returns the centre of the arc described by the given bulge and vertices
  418.  
  419. (defun LM:bulgecentre ( p1 p2 b )
  420.     (polar p1
  421.         (+ (angle p1 p2) (- (/ pi 2) (* 2 (atan b))))
  422.         (/ (* (distance p1 p2) (1+ (* b b))) 4 b)
  423.     )
  424. )
  425.  
  426. ;; Start Undo  -  Lee Mac
  427. ;; Opens an Undo Group.
  428.  
  429. (defun LM:startundo ( doc )
  430.     (LM:endundo doc)
  431.     (vla-startundomark doc)
  432. )
  433.  
  434. ;; End Undo  -  Lee Mac
  435. ;; Closes an Undo Group.
  436.  
  437. (defun LM:endundo ( doc )
  438.     (while (= 8 (logand 8 (getvar 'undoctl)))
  439.         (vla-endundomark doc)
  440.     )
  441. )
  442.  
  443. ;; Active Document  -  Lee Mac
  444. ;; Returns the VLA Active Document Object
  445.  
  446. (defun LM:acdoc nil
  447.     (LM:acdoc)
  448. )
  449.  
  450.     (append
  451.         (list 'defun 'polyinfo:chooseoutput '( sym ))
  452.         (if (vlax-method-applicable-p (vla-get-modelspace (LM:acdoc)) 'addtable)
  453.             (list
  454.                '(initget "Table TXT CSV")
  455.                '(set sym (cond ((getkword (strcat "\nChoose Output [Table/TXT/CSV] <" (eval sym) ">: "))) ((eval sym))))
  456.             )
  457.             (list
  458.                '(initget "TXT CSV")
  459.                '(set sym (cond ((getkword (strcat "\nChoose Output [TXT/CSV] <" (eval sym) ">: "))) ((eval sym))))
  460.             )
  461.         )
  462.     )
  463. )
  464.  
  465.     (strcat
  466.         "\n:: PolyInfo.lsp | Version 1.3 | \\U+00A9 Lee Mac "
  467.         (menucmd "m=$(edtime,0,yyyy)")
  468.         " www.lee-mac.com ::"
  469.         "\n:: Type \"polyinfo\" to Invoke ::"
  470.     )
  471. )
  472.  
  473. ;;----------------------------------------------------------------------;;
  474. ;;                             End of File                              ;;
  475. ;;----------------------------------------------------------------------;;
  476.  

Thanks

Master_Shake

  • Swamp Rat
  • Posts: 1447
Re: 2d and 3d polyline information ??
« Reply #1 on: January 12, 2018, 11:08:49 AM »
You asked this same question almost four years ago

https://www.theswamp.org/index.php?topic=46939.0