Extracting Layer Names & polyline orientation intersecting with Blocks

[enthralled]

Hi,

I'm working on a water network project, with many drawings similar to the attached sample "Source.dwg"

I need a lisp which finds the blocks "GPS-POINTS", one by one, extract its attributes and X/Y position;

then finds and list the layer name of each polyline ending at the insertion point of each block;

then list the layer name(s) of each polyline starting at the insertion point of the same block.

The result needs to be a CSV, which looks something like the attached "Result.xlsx".

 

Any help appreciated. Thanks

 

 

 

 

Source.dwg Result.xlsx

[mhupp]

Everything but the write to csv would only be rows 4 - 6 tho not the headers.

 

(defun C:Cords (/ SS blk sn elv pt x y cir pts SSpoly slay elay poly GPS-lst master-lst)
  (setq spm (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (prompt "\nSelect GPS-POINTS: ")
  (if (setq SS (ssget '((0 . "INSERT") (8 . "Pegs"))))
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
      (setq blk (vlax-ename->vla-object e))
      (setq SN (LM:vl-getattributevalue blk "SN"))
      (setq Elv (LM:vl-getattributevalue blk "Elevation"))
      (setq pt (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint blk))))
      (setq x (car pt))
      (setq y (cadr pt))
      (setq cir (vlax-vla-object->ename (vla-addcircle spm pt 10)))
      (setq pts (LM:ent->pts cir 50))
      (setq SSpoly (ssget "_CP" pts))
      (setq elay nil)
      (setq slay nil)
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SSpoly)))
        (setq poly (entget ent))
        (if (= (cdr (assoc 0 poly)) "LWPOLYLINE")
          (cond
            ((equal (distance (cdr (assoc 10 poly)) (list x y)) 0 0.1)
              (if (not (member (setq lay (cdr (assoc 8 poly))) slay))
                (setq slay (append slay (list lay)))
              )
            )
            ((equal (distance (cdr (assoc 10 (reverse poly))) (list x y)) 0 0.1)
              (if (not (member (setq lay (cdr (assoc 8 poly))) elay))
                (setq elay (append elay (list lay)))
              )
            )
          )
        )
      )
      (setq elay (lst2str ";" (vl-sort elay '<)))
      (setq slay (lst2str ";" (vl-sort slay '<)))
      (setq GPS-lst (list SN Elv (rtos x 2 3) (rtos x 2 3) elay slay))
      (setq master-lst (append master-lst (list GPS-lst)))
      (entdel cir)
    )
  )
  (setq master-lst (cons (list "SN" "Elevation" "X" "Y" "End point Layer(s)" "Start Point Layer(s)") master-lst))
  (if (and master-lst (setq fn (getfiled "Create Output File" "" "csv" 1)))
    (LM:WriteCSV master-lst fn)
  )
  (princ)
)

;;----------------------------------------------------------------------------;;
;; Function to convert list to string 
;; (lst2str "," lst)
(defun lst2str (dlim lst / rtn)
  (vl-load-com)
  (setq rtn (car lst) lst (cdr lst))
  (repeat (length lst)
    (setq rtn (strcat rtn dlim (car lst))
          lst (cdr lst)
    )
  )
  rtn
)

;; http://www.lee-mac.com/attributefunctions.html
;; Get Attribute Value  -  Lee Mac
;; Returns the value held by the specified tag within the supplied block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; Returns: [str] Attribute value, else nil if tag is not found.

(defun LM:vl-getattributevalue (blk tag)
  (setq tag (strcase tag))
  (vl-some '(lambda (att) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

;; http://www.lee-mac.com/entitytopointlist.html
;; Entity to Point List  -  Lee Mac
;; Returns a list of WCS points describing or approximating the supplied entity, else nil if the entity is not supported.
;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE)
;; acc - [num] Positive number determining the point density for non-linear objects
(defun LM:ent->pts (ent acc / ang bul cen cls di1 di2 enx inc itm lst num ocs rad tot typ vt1 vt2 vtl)
  (setq enx (entget ent)
        typ (cdr (assoc 0 enx))
  )
  (cond
    ((= "POINT" typ)
        (list (cdr (assoc 10 enx)))
    )
    ((= "LINE" typ)
        (mapcar '(lambda (x) (cdr (assoc x enx))) '(10 11))
    )
    ((or (= "ARC" typ) (= "CIRCLE" typ))
      (if (= "ARC" typ)
        (setq ang (cdr (assoc 50 enx))
              tot (rem (+ pi pi (- (cdr (assoc 51 enx)) ang)) (+ pi pi))
              num (fix (+ 1.0 1e-8 (* acc (/ tot (+ pi pi)))))
              inc (/ tot (float num))
              num (1+ num)
        )
        (setq ang 0.0
              tot (+ pi pi)
              num (fix (+ 1e-8 acc))
              inc (/ tot (float num))
        )
      )
      (setq cen (cdr (assoc 010 enx))
            rad (cdr (assoc 040 enx))
            ocs (cdr (assoc 210 enx))
      )
      (repeat num
        (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
              ang (+ ang inc)
        )
      )
      (reverse lst)
    )
    ((or (= "LWPOLYLINE" typ)
         (and (= "POLYLINE" typ) (zerop (logand (logior 16 64) (cdr (assoc 70 enx)))))
     )
      (if (= "LWPOLYLINE" typ)
        (setq vtl (LM:ent->pts:lwpolyvertices enx))
        (setq vtl (LM:ent->pts:polyvertices ent))
      )
      (if (setq ocs (cdr (assoc 210 enx))
                cls (= 1 (logand 1 (cdr (assoc 70 enx))))
          )
        (setq vtl (append vtl (list (cons (caar vtl) 0.0))))
      )
      (while (setq itm (car vtl))
        (setq vtl (cdr vtl)
              vt1 (car itm)
              bul (cdr itm)
              lst (cons (trans vt1 ocs 0) lst)
        )
        (if (and (not (equal 0.0 bul 1e-8)) (setq vt2 (caar vtl)))
          (progn
            (setq rad (/ (* (distance vt1 vt2) (1+ (* bul bul))) 4.0 bul)
                  cen (polar vt1 (+ (angle vt1 vt2) (- (/ pi 2.0) (* 2.0 (atan bul)))) rad)
                  rad (abs rad)
                  tot (* 4.0 (atan bul))
                  num (fix (+ 1.0 1e-8 (* acc (/ (abs tot) (+ pi pi)))))
                  inc (/ tot (float num))
                  ang (+ (angle cen vt1) inc)
            )
            (repeat (1- num)
              (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
                    ang (+ ang inc)
              )
            )
          )
        )
      )
      (reverse (if cls (cdr lst) lst))
    )
    ((= "ELLIPSE" typ)
        (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
              di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
              di2 (- di2 1e-8)
        )
      (while (< di1 di2)
        (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
              rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1)))
              di1 (+ di1 (/ di2 (1+ (fix (* acc (/ di2 rad (+ pi pi)))))))
        )
      )
      (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
    )
    ((= "SPLINE" typ)
        (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
              di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
              lst (list (vlax-curve-getstartpoint ent))
              inc (/ (- di2 di1) (float acc))
              di1 (+ di1 inc)
        )
      (repeat (1- (fix (+ 1e-8 acc)))
        (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
              di1 (+ di1 inc)
        )
      )
      (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
    )
  )
)

(defun LM:ent->pts:lwpolyvertices (enx / elv lst vtx)
  (setq elv (list (cdr (assoc 38 enx))))
  (while (setq vtx (assoc 10 enx))
    (setq enx (cdr (member vtx enx))
          lst (cons (cons (append (cdr vtx) elv) (cdr (assoc 42 enx))) lst)
    )
  )
  (reverse lst)
)

(defun LM:ent->pts:polyvertices (ent / lst vte vtx)
  (setq vte (entnext ent)
        vtx (entget vte)
  )
  (while (= "VERTEX" (cdr (assoc 0 vtx)))
    (setq lst (cons (cons (cdr (assoc 10 vtx)) (cdr (assoc 42 vtx))) lst)
          vte (entnext vte)
          vtx (entget vte)
    )
  )
  (reverse lst)
)

;; http://www.lee-mac.com/writecsv.html
;; Write CSV  -  Lee Mac
;; lst - [lst] list of lists, sublist is row of cell values
;; csv - [str] filename of CSV file to write
;; Returns T if successful, else nil

(defun LM:writecsv (lst csv / des sep)
  (if (setq des (open csv "w"))
    (progn
      (setq sep
        (cond
          ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) ( ",")
        )
      )
      (foreach row lst (write-line (LM:lst->csv row sep) des))
      (close des)
      t
    )
  )
)

;; List -> CSV  -  Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - [lst] list containing row of CSV cell values
;; sep - [str] CSV separator token

(defun LM:lst->csv (lst sep)
  (if (cdr lst)
    (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
    (LM:csv-addquotes (car lst) sep)
  )
)

(defun LM:csv-addquotes (str sep / pos)
  (cond
    ((wcmatch str (strcat "*[`" sep "\"]*"))
              (setq pos 0)
      (while (setq pos (vl-string-position 34 str pos))
        (setq str (vl-string-subst "\"\"" "\"" str pos)
              pos (+ pos 2)
        )
      )
      (strcat "\"" str "\"")
    )
    (str)
  )
)

 

Edited January 31, 2022 by mhupp

[Steven P]

This came up in another question earlier... copied and pasted the important parts of my answer from there

 

CSV... Comma Seperated Values.. and can be created using notepad... and if we can create one using notepad than AutoCAD can do that too....

 

 

 

From Lee Macs website,  http://lee-mac.com/writecsv.html , follow the example at the bottom of the page to run the lisp you can download from the top of the page, in this case using the example above it might give you this (I haven't checked this though)

 

I think replace the first part of below with the second part and add Lee Macs Lisp above to the start of yout LISP file

 

(foreach line master-lst
  ;write master-lst to cvs
)

to be:

(if (setq fn (getfiled "Create Output File" "" "csv" 1))
(LM:WriteCSV master-lst fn) ) )

 

 

[mhupp]

I'm getting an error  I think its because my list has list inside that need to be converted to strings.

and numbers that need to be converted I'll look at it when i get home tonight.

 

(("ZW705" "519.58" "-339212.096" "-339212.096" "P-1" "P-2;P-3") 
 ("W974" "509.2" "-339165.123" "-339165.123" "P-3" "P-1;P-2;P-4") 
 ("W975" "509.89" "-339188.72" "-339188.72" "P-2" "P-1;P-3"))

 

Still getting an error. cvs files look to be in japan's or something and is only one line.

Edited January 31, 2022 by mhupp

[mhupp]

Looks to be working now. Cant figure out how to merge the first row so its not in the output.

 

[enthralled]

On 1/28/2022 at 8:38 PM, mhupp said:

Everything but the write to csv would only be rows 4 - 6 tho not the headers.

 

(defun C:Cords (/ SS blk sn elv pt x y cir pts SSpoly slay elay poly GPS-lst master-lst)
  (setq spm (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (prompt "\nSelect GPS-POINTS: ")
  (if (setq SS (ssget '((0 . "INSERT") (8 . "Pegs"))))
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))
      (setq blk (vlax-ename->vla-object e))
      (setq SN (LM:vl-getattributevalue blk "SN"))
      (setq Elv (LM:vl-getattributevalue blk "Elevation"))
      (setq pt (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoint blk))))
      (setq x (car pt))
      (setq y (cadr pt))
      (setq cir (vlax-vla-object->ename (vla-addcircle spm pt 10)))
      (setq pts (LM:ent->pts cir 50))
      (setq SSpoly (ssget "_CP" pts))
      (setq elay nil)
      (setq slay nil)
      (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SSpoly)))
        (setq poly (entget ent))
        (if (= (cdr (assoc 0 poly)) "LWPOLYLINE")
          (cond
            ((equal (distance (cdr (assoc 10 poly)) (list x y)) 0 0.1)
              (if (not (member (setq lay (cdr (assoc 8 poly))) slay))
                (setq slay (append slay (list lay)))
              )
            )
            ((equal (distance (cdr (assoc 10 (reverse poly))) (list x y)) 0 0.1)
              (if (not (member (setq lay (cdr (assoc 8 poly))) elay))
                (setq elay (append elay (list lay)))
              )
            )
          )
        )
      )
      (setq elay (lst2str ";" (vl-sort elay '<)))
      (setq slay (lst2str ";" (vl-sort slay '<)))
      (setq GPS-lst (list SN Elv (rtos x 2 3) (rtos x 2 3) elay slay))
      (setq master-lst (append master-lst (list GPS-lst)))
      (entdel cir)
    )
  )
  (setq master-lst (cons (list "SN" "Elevation" "X" "Y" "End point Layer(s)" "Start Point Layer(s)") master-lst))
  (if (and master-lst (setq fn (getfiled "Create Output File" "" "csv" 1)))
    (LM:WriteCSV master-lst fn)
  )
  (princ)
)

;;----------------------------------------------------------------------------;;
;; Function to convert list to string 
;; (lst2str "," lst)
(defun lst2str (dlim lst / rtn)
  (vl-load-com)
  (setq rtn (car lst) lst (cdr lst))
  (repeat (length lst)
    (setq rtn (strcat rtn dlim (car lst))
          lst (cdr lst)
    )
  )
  rtn
)

;; http://www.lee-mac.com/attributefunctions.html
;; Get Attribute Value  -  Lee Mac
;; Returns the value held by the specified tag within the supplied block, if present.
;; blk - [vla] VLA Block Reference Object
;; tag - [str] Attribute TagString
;; Returns: [str] Attribute value, else nil if tag is not found.

(defun LM:vl-getattributevalue (blk tag)
  (setq tag (strcase tag))
  (vl-some '(lambda (att) (if (= tag (strcase (vla-get-tagstring att))) (vla-get-textstring att))) (vlax-invoke blk 'getattributes))
)

;; http://www.lee-mac.com/entitytopointlist.html
;; Entity to Point List  -  Lee Mac
;; Returns a list of WCS points describing or approximating the supplied entity, else nil if the entity is not supported.
;; ent - [ent] Entity name to be described by point list (POINT/LINE/ARC/CIRCLE/LWPOLYLINE/POLYLINE/ELLIPSE/SPLINE)
;; acc - [num] Positive number determining the point density for non-linear objects
(defun LM:ent->pts (ent acc / ang bul cen cls di1 di2 enx inc itm lst num ocs rad tot typ vt1 vt2 vtl)
  (setq enx (entget ent)
        typ (cdr (assoc 0 enx))
  )
  (cond
    ((= "POINT" typ)
        (list (cdr (assoc 10 enx)))
    )
    ((= "LINE" typ)
        (mapcar '(lambda (x) (cdr (assoc x enx))) '(10 11))
    )
    ((or (= "ARC" typ) (= "CIRCLE" typ))
      (if (= "ARC" typ)
        (setq ang (cdr (assoc 50 enx))
              tot (rem (+ pi pi (- (cdr (assoc 51 enx)) ang)) (+ pi pi))
              num (fix (+ 1.0 1e-8 (* acc (/ tot (+ pi pi)))))
              inc (/ tot (float num))
              num (1+ num)
        )
        (setq ang 0.0
              tot (+ pi pi)
              num (fix (+ 1e-8 acc))
              inc (/ tot (float num))
        )
      )
      (setq cen (cdr (assoc 010 enx))
            rad (cdr (assoc 040 enx))
            ocs (cdr (assoc 210 enx))
      )
      (repeat num
        (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
              ang (+ ang inc)
        )
      )
      (reverse lst)
    )
    ((or (= "LWPOLYLINE" typ)
         (and (= "POLYLINE" typ) (zerop (logand (logior 16 64) (cdr (assoc 70 enx)))))
     )
      (if (= "LWPOLYLINE" typ)
        (setq vtl (LM:ent->pts:lwpolyvertices enx))
        (setq vtl (LM:ent->pts:polyvertices ent))
      )
      (if (setq ocs (cdr (assoc 210 enx))
                cls (= 1 (logand 1 (cdr (assoc 70 enx))))
          )
        (setq vtl (append vtl (list (cons (caar vtl) 0.0))))
      )
      (while (setq itm (car vtl))
        (setq vtl (cdr vtl)
              vt1 (car itm)
              bul (cdr itm)
              lst (cons (trans vt1 ocs 0) lst)
        )
        (if (and (not (equal 0.0 bul 1e-8)) (setq vt2 (caar vtl)))
          (progn
            (setq rad (/ (* (distance vt1 vt2) (1+ (* bul bul))) 4.0 bul)
                  cen (polar vt1 (+ (angle vt1 vt2) (- (/ pi 2.0) (* 2.0 (atan bul)))) rad)
                  rad (abs rad)
                  tot (* 4.0 (atan bul))
                  num (fix (+ 1.0 1e-8 (* acc (/ (abs tot) (+ pi pi)))))
                  inc (/ tot (float num))
                  ang (+ (angle cen vt1) inc)
            )
            (repeat (1- num)
              (setq lst (cons (trans (polar cen ang rad) ocs 0) lst)
                    ang (+ ang inc)
              )
            )
          )
        )
      )
      (reverse (if cls (cdr lst) lst))
    )
    ((= "ELLIPSE" typ)
        (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
              di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
              di2 (- di2 1e-8)
        )
      (while (< di1 di2)
        (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
              rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatdist ent di1)))
              di1 (+ di1 (/ di2 (1+ (fix (* acc (/ di2 rad (+ pi pi)))))))
        )
      )
      (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
    )
    ((= "SPLINE" typ)
        (setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
              di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
              lst (list (vlax-curve-getstartpoint ent))
              inc (/ (- di2 di1) (float acc))
              di1 (+ di1 inc)
        )
      (repeat (1- (fix (+ 1e-8 acc)))
        (setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
              di1 (+ di1 inc)
        )
      )
      (reverse (if (vlax-curve-isclosed ent) lst (cons (vlax-curve-getendpoint ent) lst)))
    )
  )
)

(defun LM:ent->pts:lwpolyvertices (enx / elv lst vtx)
  (setq elv (list (cdr (assoc 38 enx))))
  (while (setq vtx (assoc 10 enx))
    (setq enx (cdr (member vtx enx))
          lst (cons (cons (append (cdr vtx) elv) (cdr (assoc 42 enx))) lst)
    )
  )
  (reverse lst)
)

(defun LM:ent->pts:polyvertices (ent / lst vte vtx)
  (setq vte (entnext ent)
        vtx (entget vte)
  )
  (while (= "VERTEX" (cdr (assoc 0 vtx)))
    (setq lst (cons (cons (cdr (assoc 10 vtx)) (cdr (assoc 42 vtx))) lst)
          vte (entnext vte)
          vtx (entget vte)
    )
  )
  (reverse lst)
)

;; http://www.lee-mac.com/writecsv.html
;; Write CSV  -  Lee Mac
;; lst - [lst] list of lists, sublist is row of cell values
;; csv - [str] filename of CSV file to write
;; Returns T if successful, else nil

(defun LM:writecsv (lst csv / des sep)
  (if (setq des (open csv "w"))
    (progn
      (setq sep
        (cond
          ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) ( ",")
        )
      )
      (foreach row lst (write-line (LM:lst->csv row sep) des))
      (close des)
      t
    )
  )
)

;; List -> CSV  -  Lee Mac
;; Concatenates a row of cell values to be written to a CSV file.
;; lst - [lst] list containing row of CSV cell values
;; sep - [str] CSV separator token

(defun LM:lst->csv (lst sep)
  (if (cdr lst)
    (strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
    (LM:csv-addquotes (car lst) sep)
  )
)

(defun LM:csv-addquotes (str sep / pos)
  (cond
    ((wcmatch str (strcat "*[`" sep "\"]*"))
              (setq pos 0)
      (while (setq pos (vl-string-position 34 str pos))
        (setq str (vl-string-subst "\"\"" "\"" str pos)
              pos (+ pos 2)
        )
      )
      (strcat "\"" str "\"")
    )
    (str)
  )
)

 

Thanks!

When I load it on my Source.dwg file, it's asking to select GPS-POINTS. After selection and hiting enter, I get this:

Error: lisp value has no coercion to VARIANT with this type:  (-339189.0 -94692.9 0.0)

 

On the other hand, I found this LISP (attached) done by former company staff, which works (with only certain layer naming though). So I'm good for now Thanks!

tee.LSP