Offset for each circle center (x,y) from origin and make table

[syedmeesamali]

Hello Everyone, Happy to be part of this CAD forum. I need your help with the following problem.

I have a drawing having circles at various locations (almost 120 circles) each representing a coring location. I need to make a table in the same drawing showing the number of that circle as well as its x,y coordinates with reference from a specific origin to be chosen (not the CAD drawing origin). 

Any help is appreciated as i am new to Visual LISP (Done programming in other languages but not in a LIST processing language). 

Thanks.

 

[Emmanuel Delay]

How can we know the core# ?  Is that a text next to the circle?

[syedmeesamali]

Actually core number should also be added by LISP. Even if there is existing core number I don't mind it as I need offsets for circular portion only. 

[syedmeesamali]

I found one code which helps me to find out the x and y from a reference of 0,0 origin. My next problem is to find out size of each circle (by some modification or data extraction from code below) as well as sequentially number the cores (or circles). 

 

(defun c:CircleExport ()
  (setq sset (ssget '((-4 . "<OR")
                                  (0 . "CIRCLE")
                      (-4 . "OR>"))))
  (if sset
    (progn
      (setq itm 0 num (sslength sset))
      (setq fn (getfiled "Point Export File" "" "txt" 1))
      (if (/= fn nil)
        (progn
          (setq fh (open fn "w"))
          (while (< itm num)
            (setq hnd (ssname sset itm))
            (setq ent (entget hnd))
            (setq obj (cdr (assoc 0 ent)))
            (cond 
              ((= obj "CIRCLE")
                (setq pnt (cdr (assoc 10 ent)))
                (princ (strcat 
                               (rtos (car  pnt) 2 8) ";"
                               (rtos (cadr pnt) 2 8) ";"
                               (rtos (caddr pnt) 2 8)) fh)
                (princ "\n" fh)
              ) 
              (t nil)
            )
            (setq itm (1+ itm))
          )
          (close fh)
        )
      )
    )
  )
  (princ)
)
(princ "\nCircleExport loaded, type CircleExport to run. ")
(princ)

 

[dlanorh]

Are the core circles on a specific layer? If not how can you identify what is a core and what is just a circle?

Edited July 17, 2019 by dlanorh

[Emmanuel Delay]

This should work

(not sure about your prefered settings, like the size of the texts and table, I assume you want text height of 2.5)

 

COMMAND OCC (for Offset Circle Center)

;;;;;;;;;;;;;;;;;;;
;; draw text object
(defun Text (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str)))
)


;;;;;;;;;;;;;;;;;;;
(vl-load-com)

(defun inserttable (lst pt / ht htc tab i j row tb acObj acDoc space)
  ;; settings, text height, cel height
  (setq ht 2.5)
  (setq htc 4.0)
 
  ;; document, model space, ...
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )

  (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht)  ))  ;;
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
 
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i htc)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      (princ "\n")
      (princ  (nth j row))
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
  ;; default Autocad expects a totle row.  If the first row has more than 1 cel, let's unmerge this row
  (if (> (length (nth 0 lst)) 1)
    (vla-unMergeCells tab 0 0 0 0)
  )
  tab
)

;; Offset for each Circle Center
(defun c:occ ( / lst ss bp pt i ip radi)
  ;; select circles
  (princ "\nSelect circles then press enter: ")
  (setq ss (ssget (list (cons 0 "CIRCLE"))))
  (setq bp (getpoint "\nBase point for offset: "))
  (setq pt (getpoint "\nInsert point of the table: "))
 
  ;; make the list
  (setq lst (list
    (list "Core#" "x" "y")  ;; head
  ))
  (setq i 0)
  (repeat (sslength ss)
    (setq ip (cdr (assoc 10 (entget (ssname ss i)))))    ;; circle center
    (setq radi (cdr (assoc 40 (entget (ssname ss i)))))  ;; circle radius (so we know where to put the label)
    ;; append the list
    (setq lst (append lst (list
      (list  
        (+ i 1)  ;; 1-based counter, Core#
        (rtos (car ip) 2 2)  ;; 2 decimals, feel free to change this
        (rtos (cadr ip) 2 2)
      )
    )))
    (Text
      (list (+ (nth 0 ip) radi) (- (nth 1 ip) radi) )
      2.5
      (strcat "Core " (itoa (+ i 1)))
    )
    (setq i (+ i 1))
  )
  (inserttable lst pt)
)

 

Edited July 17, 2019 by Emmanuel Delay

[syedmeesamali]

This is just excellent Mr. Emmanuel. Many thanks for your valuable time and effort. There is now one final thing I would like your help with. The text size for the cores is too small as shown below. For Table I just scaled it to suit my needs.

 

Again many thanks for your efforts. 

[Emmanuel Delay]

What text height do you want?  I'll scale it up

[syedmeesamali]

It should be 200. And much better if the color of numbering is something else like maybe red or blue. 

[Emmanuel Delay]

;;;;;;;;;;;;;;;;;;;
;; draw text object
(defun Text (pt hgt str color)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 62 color)
                 (cons 1  str)))
)


;;;;;;;;;;;;;;;;;;;
(vl-load-com)

(defun inserttable (lst pt / ht htc tab i j row tb acObj acDoc space)
  ;; settings, text height, cel height
  (setq ht 200)
  (setq htc 380)
 
  ;; document, model space, ...
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )

  (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht)  ))  ;;
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
 
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i htc)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      (princ "\n")
      (princ  (nth j row))
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
  ;; default Autocad expects a totle row.  If the first row has more than 1 cel, let's unmerge this row
  (if (> (length (nth 0 lst)) 1)
    (vla-unMergeCells tab 0 0 0 0)
  )
  tab
)

;; Offset for each Circle Center
(defun c:occ ( / lst ss bp pt i ip radi)
  ;; select circles
  (princ "\nSelect circles then press enter: ")
  (setq ss (ssget (list (cons 0 "CIRCLE"))))
  (setq bp (getpoint "\nBase point for offset: "))
  (setq pt (getpoint "\nInsert point of the table: "))
 
  ;; make the list
  (setq lst (list
    (list "Core#" "x" "y")  ;; head
  ))
  (setq i 0)
  (repeat (sslength ss)
    (setq ip (cdr (assoc 10 (entget (ssname ss i)))))    ;; circle center
    (setq radi (cdr (assoc 40 (entget (ssname ss i)))))  ;; circle radius (so we know where to put the label)
    ;; append the list
    (setq lst (append lst (list
      (list  
        (+ i 1)  ;; 1-based counter, Core#
        (rtos (car ip) 2 2)  ;; 2 decimals, feel free to change this
        (rtos (cadr ip) 2 2)
      )
    )))
    (Text
      (list (+ (nth 0 ip) radi) (- (nth 1 ip) radi) )
      200
      (strcat "Core " (itoa (+ i 1)))
      160  ;; blue
    )
    (setq i (+ i 1))
  )
  (inserttable lst pt)
)

[syedmeesamali]

Excellent. Many thanks Mr. Emmanuel. 

[syedmeesamali]

Just one last request. I also need to add one column to table showing the SIZE of each core. I have only two size i.e. 75mm and 150mm cores. So it will be really helpful if 2nd column is for size in mm and then x and y as usual. 

[dlanorh]

1 hour ago, syedmeesamali said:

Just one last request. I also need to add one column to table showing the SIZE of each core. I have only two size i.e. 75mm and 150mm cores. So it will be really helpful if 2nd column is for size in mm and then x and y as usual. 

 

It would help to know if the core sizes are diameters or radii

[Emmanuel Delay]

I added the Radius .

 

If you want the diameter, then change

(rtos radi 2 2)

to

(rtos (* radi 2.0) 2 2)

If you want the volume:

(rtos (* pi (* radi radi)) 2 2)

 

And thange the title (list "Core#" "x" "y" "Radius")  ;; head

 

;;;;;;;;;;;;;;;;;;;
;; draw text object
(defun Text (pt hgt str color)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 62 color)
                 (cons 1  str)))
)


;;;;;;;;;;;;;;;;;;;
(vl-load-com)

(defun inserttable (lst pt / ht htc tab i j row tb acObj acDoc space)
  ;; settings, text height, cel height
  (setq ht 200)
  (setq htc 380)
 
  ;; document, model space, ...
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )

  (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht)  ))  ;;
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
 
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i htc)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      (princ "\n")
      (princ  (nth j row))
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
  ;; default Autocad expects a totle row.  If the first row has more than 1 cel, let's unmerge this row
  (if (> (length (nth 0 lst)) 1)
    (vla-unMergeCells tab 0 0 0 0)
  )
  tab
)

;; Offset for each Circle Center
(defun c:occ ( / lst ss bp pt i ip radi)
  ;; select circles
  (princ "\nSelect circles then press enter: ")
  (setq ss (ssget (list (cons 0 "CIRCLE"))))
  (setq bp (getpoint "\nBase point for offset: "))
  (setq pt (getpoint "\nInsert point of the table: "))
 
  ;; make the list
  (setq lst (list
    (list "Core#" "x" "y" "Radius")  ;; head
  ))
  (setq i 0)
  (repeat (sslength ss)
    (setq ip (cdr (assoc 10 (entget (ssname ss i)))))    ;; circle center
    (setq radi (cdr (assoc 40 (entget (ssname ss i)))))  ;; circle radius (so we know where to put the label)
    ;; append the list
    (setq lst (append lst (list
      (list  
        (+ i 1)  ;; 1-based counter, Core#
        (rtos (car ip) 2 2)  ;; 2 decimals, feel free to change this
        (rtos (cadr ip) 2 2)
        (rtos radi 2 2)
      )
    )))
    (Text
      (list (+ (nth 0 ip) radi) (- (nth 1 ip) radi) )
      200
      (strcat "Core " (itoa (+ i 1)))
      160  ;; blue
    )
    (setq i (+ i 1))
  )
  (inserttable lst pt)
)

 

[syedmeesamali]

Many Thanks. Just sharing my final image so that it can a good reference for somebody looking for similar problem. In the meanwhile I am trying to get better grasp of VLisp as I have background in Java, C++, Python and VBA (very different from list programming). 

 

[syedmeesamali]

@Emmanuel Delay I need one more help. Due to big size of drawing I will take two points as origin for the (x,y) calculation. e.g. one point will be same original origin i.e. 0,0 but the new point will be somewhere around (0, 25000) position. What change do i need to make to take my offsets for upper portion from this new origin? All the details will remain same but i need to split the code in to two separate origin reference points. 

[BIGAL]

You set UCS origin to a new point this may do what you want no code change

[syedmeesamali]

@BIGAL OK I tried the below but whenever the program finishes still the circle offsets are taken from original origin i.e. 0,0 (WCS) and not the new WCS which is 0,33000 from the original.

 

(setq pt1 "0,33000,0") 
(command ".UCS" "Origin" pt1)

What should i change?

[Emmanuel Delay]

Answering a further request, asked in another topic

>> Is there any way to make it bit more regular (like starting from bottom left and continuing in some logical fashion) or there is no way around?

 

I sorted the ss selection by X value (of the insert point of the circles).  That makes it a lot more searchable.

I also ask the user for a start number.  So if, for example, you have a North wing of a building with 130 cores, you can start the South wing with number 131.

 

(I removed the text "Core", set the text height to 300 and color to 200 of the labels).

 

Notice, I could reuse function insert_sorted  to sort the ss selection, here by the x-value instead of by an ID

 

;;;;;;;;;;;;;;;;;;;
;; draw text object
(defun Text (pt hgt str color)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 62 color)
                 (cons 1  str)))
)


;;;;;;;;;;;;;;;;;;;
(vl-load-com)

(defun inserttable (lst pt / ht htc tab i j row tb acObj acDoc space)
  ;; settings, text height, cel height
  (setq ht 200)
  (setq htc 380)
 
  ;; document, model space, ...
  (setq acObj (vlax-get-acad-object)
        acDoc (vla-get-activedocument acObj)
        space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
  )

  (setq tab (vla-addtable space (vlax-3d-point pt) (length lst) (length (cadr lst)) (* 1.1 ht) (* 10.0 ht)  ))  ;;
  (vla-SetTextHeight tab 1 ht)
  (vla-SetTextHeight tab 2 ht)
  (vla-SetTextHeight tab 4 ht)
  
  (vla-put-VertCellMargin tab (* 0.14 ht))
  
  (setq i 0)
  (repeat (length lst)  ;; iterates the rows
    (vla-setrowHeight tab i htc)
    (setq row (nth i lst))
    (setq j 0)
    (repeat (length row)  ;; iterates the cols in the row
      ;;(princ "\n")
      ;;(princ  (nth j row))
      (vla-SetText tab i j (nth j row) )
      (setq j (+ j 1))
    )
    (setq i (+ i 1))
  )
  ;; default Autocad expects a totle row.  If the first row has more than 1 cel, let's unmerge this row
  (if (> (length (nth 0 lst)) 1)
    (vla-unMergeCells tab 0 0 0 0)
  )
  tab
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; there is a list of lists.  (list (list ID IND)) .  If holds a numeric ID (1 2 3 ...);
;; IND holds the index of the unsorted list
;; This function inseerts a new item, its position in the list depending on its ID.
(defun insert_sorted (lst_sorted id ind / lst_new inserted id_ i)
  (setq inserted nil)
  (setq lst_new (list))
  (if (= (length lst_sorted) 0)
    (progn
      ;; first item, so we insert it
      (setq lst_new (list (list
        id ind
      )))
    )
    (progn
      (setq i 0)
      ;; we loop through the existing list.  When the new ID is smaller than the ID in the list  => we insert the new item there
      (foreach item lst_sorted
        (setq id_ (nth 0 item))
        (if (and (= inserted nil) (< id id_)) (progn
          (setq lst_new (append lst_new (list (list
            id ind
          ))))
          (setq inserted T)
        ))
        ;; continue copying the items from lst_sorted to lst_new
        (setq lst_new (append lst_new (list (list
          (nth 0 item) (nth 1 item)
        ))))
        (setq i (+ i 1))
      )
      ;; if the item isn't inserted yet we add it to the end
      (if (= inserted nil)
        (setq lst_new (append lst_new (list (list
          id ind
        ))))
      )
    )
  )
  lst_new  
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun sort_ss_by_xy (ss xOry / i j data item ip)
 
  (setq i 0)
  (setq data (list))
  (repeat (sslength ss)
    (setq ip (cdr (assoc 10 (entget (ssname ss i)))))  ;; insert point of the core
    (if (= xOry "x")
      ;; sort by x
      (setq data (insert_sorted data (nth 0 ip) i))
      ;; sort by y
      (setq data (insert_sorted data (nth 1 ip) i))
    )
    (setq i (+ i 1))
  )
  ;;(princ data)
 
  ;; now let's rebuild a ss selection, but sorted like data
  (setq ss_sorted (ssadd))
  (foreach item data
    (setq j (nth 1 item))  ;; j now holds the index of the ss selection
    (ssadd (ssname ss j) ss_sorted)
  )
  ss_sorted
)

;; Offset for each Circle Center
(defun c:occ ( / lst startnumber ss ss_sorted bp pt i ip radi)
  ;; select circles
  (princ "\nSelect circles then press enter: ")
  (setq ss (ssget (list (cons 8 "Cores") (cons 0 "CIRCLE"))))
 
  (setq ss (sort_ss_by_xy ss "x"))
 
  (setq bp (getpoint "\nBase point for offset: "))
  (setq pt (getpoint "\nInsert point of the table: "))
 
  (setq startnumber (getint "\nStart Number: "))
 
  ;; make the list
  (setq lst (list
    (list "Core#" "x" "y" "Radius")  ;; head
  ))
  (setq i 0)
  (repeat (sslength ss)
    (setq ip (cdr (assoc 10 (entget (ssname ss i)))))    ;; circle center
    (setq radi (cdr (assoc 40 (entget (ssname ss i)))))  ;; circle radius (so we know where to put the label)
    ;; append the list
    (setq lst (append lst (list
      (list  
        (+ i startnumber )  ;; counter, starting with user set start number
        (rtos (car ip) 2 2)  ;; 2 decimals, feel free to change this
        (rtos (cadr ip) 2 2)
        (rtos radi 2 2)
      )
    )))
    (Text
      (list (+ (nth 0 ip) (* 2. radi)) (- (nth 1 ip) radi) )
      300
      (itoa (+ i startnumber))
      200  ;; purple
    )
    (setq i (+ i 1))
  )
  (inserttable lst pt)
)

Edited July 23, 2019 by Emmanuel Delay

[syedmeesamali]

Wow you're the hero Mr. Emmanuel. Super thanks for all your efforts and help. Now I got full set of tools to deal with messy corings and got complete control over them. 

 

BTW I also bought the book "AutoCAD Developers Guide to Visual LISP" in order make myself more familiarized with AutoLISP and also to develop my own programs. 

 

Thanks a lot.