Jump to content

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


syedmeesamali

Recommended Posts

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.

target.thumb.png.17617bf9558eefdebfc3bc5b6628acef.png

 

Link to comment
Share on other sites

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. 

Link to comment
Share on other sites

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)

 

Link to comment
Share on other sites

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 by dlanorh
Link to comment
Share on other sites

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 by Emmanuel Delay
Link to comment
Share on other sites

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.

image.png.34ae43d792890a59414df1acb758468c.png

 

Again many thanks for your efforts. 

Link to comment
Share on other sites



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


  • Like 1
Link to comment
Share on other sites

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. 

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

 

Link to comment
Share on other sites

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

 

image.thumb.png.4c6759f3d3500a489d1e60e6ec0dc6df.png

Link to comment
Share on other sites

@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. 

Link to comment
Share on other sites

@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?

Link to comment
Share on other sites

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 by Emmanuel Delay
  • Thanks 1
Link to comment
Share on other sites

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. 🌻

  • Like 1
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...