BCount Leader LISP

[jmarck]

I am a landscape architect and we typically do call-outs for all of our plant symbols on a drawing. Basically I have many clusters of different plant symbols, which are blocks, and I want to label them. Is there a lisp that would do a bcount and then create a leader with the count shown for example:

(10) AS
(4) RE
(6) TR

Thanks

[BlackBox]

I am a landscape architect and we typically do call-outs for all of our plant symbols on a drawing. Basically I have many clusters of different plant symbols, which are blocks, and I want to label them. Is there a lisp that would do a bcount and then create a leader with the count shown for example:

(10) AS
(4) RE
(6) TR

Thanks

Welcome to the forums!

This is all I have for the moment, but I'll try to get you one that can do all of them in one shot shortly.

Hope this helps:

(defun c:TEST ( / oldCmd eName1 blkName cnt ss label)
  (setq oldCmd (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (prompt "\n  >> Select First Block, Then Multiple, <Enter> to Exit: ")
  (while
    (/= nil (setq eName1 (car (entsel))))
      (progn
        (redraw eName1 3)
        (setq blkName (cdr (assoc 2 (entget eName1))))
        (setq cnt
                  (rtos
                    (sslength
                      (ssadd eName1
                        (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))))
                    2
                    0))
        (redraw eName1 4)
        (setq label (strcat "(" cnt ") " blkName))
        (command "._leader" pause pause "f" "n" "" label "")
        (prompt (strcat "\n  >>  Block Count  >>  " label))))
  (setvar 'cmdecho oldCmd)
  (princ)) ;_end defun

Cheers!

[fixo]

I am a landscape architect and we typically do call-outs for all of our plant symbols on a drawing. Basically I have many clusters of different plant symbols, which are blocks, and I want to label them. Is there a lisp that would do a bcount and then create a leader with the count shown for example:

(10) AS
(4) RE
(6) TR

Thanks

Welcome on board
Here is my 2 cents
change the text style name and layer name
inside the code to your suit

;; convert radians to degrees
(defun rtd (a)
(* 180.0 (/ a pi))
)
;;  Counts equivalent items in list

(defun count_occurs	(lst)
  (if (car lst)
    (cons (cons	(car lst)
		(length	(vl-remove-if-not
			  (function (lambda (x)
				      (eq x (car lst))))
			  lst))
		)
	  (count_occurs
	    (vl-remove-if
	      (function	(lambda	(x)
			  (eq x (car lst))))
	      lst)
	    )
	  )
    )
  )

;;			Main part			;;
  (defun C:LCOUNT (/ acsp adoc ang atch axss com_data count_lst count_text ldobj mtx osm p1 p2 ss)

    (vl-load-com)
    (setq adoc (vla-get-activedocument
		 (vlax-get-acad-object)
	       )
	  acsp (vla-get-modelspace adoc)
    )
    (setvar "cmdecho" 0)
    (setq osm (getvar "osmode"))
    (setvar "osmode" 0)
    (vla-endundomark adoc)
    (vla-startundomark adoc)

    (vl-cmdf "zoom" "a")    
    (setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 410 (getvar "CTAB")))))
   (vl-cmdf "zoom" "P")
    (setq axss (vla-get-activeselectionset adoc))
    

    (vlax-for a	axss
      (setq com_data (cons (vla-get-effectivename a) com_data))
    )

   (setq count_lst (count_occurs com_data))

   (setq count_lst (vl-sort count_lst (function (lambda (a b)(< (cdr a)(cdr b))))))
    (setq count_text
	   (apply 'strcat
	   (mapcar (function (lambda(x)(strcat "(" (itoa (cdr x)) ") " (car x) "\\P")))
    count_lst)))

    (setq p1 (getpoint "\nPick leader arrow point: ")
	  p2 (getpoint p1 "\nPick text location: ")
	  )
    (setq ang (rtd (angle p1 p2))
)

(cond
((< 0 ang 90)(setq atch 4))
((< 90 ang 180)(setq atch 6))
((< 180 ang 270)(setq atch 6))
((< 270 ang 360)(setq atch 4)))

  

  (setq	mtx (vlax-invoke
	      acsp 'AddMText p2	0.0 count_text)
  )
  (vlax-put mtx 'StyleName "Standard");<-- text style name
  (vlax-put mtx 'Height 0.2);<--text height
  (vlax-put mtx 'Layer "leader") ;<--layer name
  (vlax-put mtx 'Color 256);<--color bylayer
  
  (vlax-put mtx 'AttachmentPoint atch)
  (vlax-put mtx 'InsertionPoint  p2)


  (setq ldobj (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
	)
  (vla-put-layer ldobj (vlax-get mtx 'Layer))
  (vla-put-arrowheadsize ldobj (vlax-get mtx 'Height))
  (setvar "osmode" osm)
  (setvar "cmdecho" 1)
  (vla-endundomark adoc)
  (princ)
 ) 
(princ "\n\t\t***\tStart command with LCOUNT...\t***")
(prin1)

hth

~'J'~

[BlackBox]

...
I'll try to get you one that can do all of them in one shot shortly.
...

I this is what you're looking for:

(vl-load-com)
(defun c:TEST2 (/ blockTable oldCmd blockName ss namesList count blockCountList label)
  (prompt "\n  >> Select Blocks: ")
  (if (setq ss (ssget '((0 . "INSERT"))))
    (progn
      (cond
          (*activeDoc*)
          ((setq *activeDoc* (vla-get-activedocument (vlax-get-acad-object)))))
      (setq blockTable (vla-get-blocks *activeDoc*))
      (setq oldCmd (getvar 'cmdecho))
      (setvar 'cmdecho 0)
      (vlax-for x (setq ss (vla-get-activeselectionset *activeDoc*))
        (if
          (and
            (not (vl-position (setq blockName (vla-get-name x))namesList))
            (= :vlax-false (vla-get-isxref (vla-item *blockTable* blockName))))
          (setq namesList (cons (vla-get-name x) namesList))))
      (foreach name  namesList
        (setq count 0)
        (vlax-for y  ss
          (if (= name (vla-get-name y))
            (setq count (1+ count))))
        (setq blockCountList (cons (cons name count) blockCountList)))
    (setq label
                (apply
                  'strcat
                    (mapcar
                      '(lambda (z)
                          (strcat "(" (rtos (cdr z) 2 0) ") " (car z) "\\P"))
                      blockCountList)))
    (command "._leader" pause pause "format" "none" "" label "")))
  (setvar 'cmdecho oldCmd)
  (princ)) ;_end defun

[BlackBox]

Technically, you posted first... but this looks familiar....

...
Here is my 2 cents
...

...
    (setq count_text
  (apply 'strcat
  (mapcar (function (lambda(x)(strcat "(" (itoa (cdr x)) ") " (car x) "\\P")))
  count_lst)))
...

Great minds, Fixo, you and I.

[BlackBox]

Although, is this really what you want to do?

Because this will catch all blocks, including XREFs

Welcome on board
Here is my 2 cents
change the text style name and layer name
inside the code to your suit

;; convert radians to degrees
(defun rtd (a)
(* 180.0 (/ a pi))
)
;;  Counts equivalent items in list
(defun count_occurs (lst)
  (if (car lst)
    (cons (cons (car lst)
  (length (vl-remove-if-not
     (function (lambda (x)
          (eq x (car lst))))
     lst))
  )
   (count_occurs
     (vl-remove-if
       (function (lambda (x)
     (eq x (car lst))))
       lst)
     )
   )
    )
  )
;;   Main part   ;;
  (defun C:LCOUNT (/ acsp adoc ang atch axss com_data count_lst count_text ldobj mtx p1 p2 ss)
    (vl-load-com)
    (setq adoc (vla-get-activedocument
   (vlax-get-acad-object)
        )
   acsp (vla-get-modelspace adoc)
    )
    (setvar "cmdecho" 0)
    (vla-endundomark adoc)
    (vla-startundomark adoc)
    (vl-cmdf "zoom" "a")
    (vl-cmdf "zoom" ".85x")
   ;; Is this really what you want to do?
    (setq ss (ssget "_X" (list (cons 0 "INSERT"))))
    (setq axss (vla-get-activeselectionset adoc))
    (setq com_data nil)      ;for debug only
    (vlax-for a axss
      (setq com_data (cons (vla-get-effectivename a) com_data))
    )
   (setq count_lst (count_occurs com_data))
    (setq count_text
    (apply 'strcat
    (mapcar (function (lambda(x)(strcat "(" (itoa (cdr x)) ") " (car x) "\\P")))
    count_lst)))
    (setq p1 (getpoint "\nPick leader arrow point: ")
   p2 (getpoint p1 "\nPick text location: ")
   )
    (setq ang (rtd (angle p1 p2))
)
(cond
((< 0 ang 90)(setq atch 4))
((< 90 ang 180)(setq atch 6))
((< 180 ang 270)(setq atch 6))
((< 270 ang 360)(setq atch 4)))
 
  (setq mtx (vlax-invoke
       acsp 'AddMText p2 0.0 count_text)
  )
  (vlax-put mtx 'StyleName "Standard");<-- text style name
  (vlax-put mtx 'Height 0.2);<--text height
  (vlax-put mtx 'Layer "leader") ;<--layer name
  (vlax-put mtx 'Color 256);<--color bylayer
 
  (vlax-put mtx 'AttachmentPoint atch)
  (vlax-put mtx 'InsertionPoint  p2)
 
  (setq ldobj (vlax-invoke
    acsp
    'Addleader
    (apply 'append (list p1 p2))
    mtx
    acLineWithArrow
  )
 )
 (vla-put-arrowheadsize (vlax-get mtx 'Height))
   (vla-endundomark adoc)
   (princ)
 ) 
(princ "\n\t\t***\tStart command with LCOUNT...\t***")
(prin1)

hth

~'J'~

[jmarck]

Welcome to the forums!

This is all I have for the moment, but I'll try to get you one that can do all of them in one shot shortly.

Hope this helps:

(defun c:TEST ( / oldCmd eName1 blkName cnt ss label)
  (setq oldCmd (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (prompt "\n  >> Select First Block, Then Multiple, <Enter> to Exit: ")
  (while
    (/= nil (setq eName1 (car (entsel))))
      (progn
        (redraw eName1 3)
        (setq blkName (cdr (assoc 2 (entget eName1))))
        (setq cnt
                  (rtos
                    (sslength
                      (ssadd eName1
                        (setq ss (ssget (list '(0 . "INSERT") (cons 2 blkName))))))
                    2
                    0))
        (redraw eName1 4)
        (setq label (strcat "(" cnt ") " blkName))
        (command "._leader" pause pause "f" "n" "" label "")
        (prompt (strcat "\n  >>  Block Count  >>  " label))))
  (setvar 'cmdecho oldCmd)
  (princ)) ;_end defun

Cheers!

Perfect-- Now is there a way to select multiple different blocks and have it list out the number of each block?

Thanks

[fixo]

Perfect-- Now is there a way to select multiple different blocks and have it list out the number of each block?

Thanks

Just change this line of code in my routine:

(setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 410 (getvar "CTAB")))))

on this one

(setq ss (ssget  (list (cons 0 "INSERT"))))

to select blocks on screen as many as you need

~'J'~

[fixo]

Although, is this really what you want to do?

Because this will catch all blocks, including XREFs

Good job,
Regards,

~'J'~

[jmarck]

Just change this line of code in my routine:

(setq ss (ssget "_X" (list (cons 0 "INSERT")(cons 410 (getvar "CTAB")))))

on this one

(setq ss (ssget  (list (cons 0 "INSERT"))))

to select blocks on screen as many as you need

~'J'~

I am getting an error:

; error: no function definition: VLA-GET-EFFECTIVENAME

I am probably doing something wrong. It also zooms extents with every click.Thanks again for your help.