Jump to content

gruops of blocks

grifo

By grifo
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

grifo Newbie

grifo

Posted
Posted

Hello everyone,
I just signed up to the forum
I am a beginner in Lisp programming
I would need some examples in Lisp to solve the following problems:
1-I know the name of a group that is composed of blocks, I would like to know the names of the blocks of that particular group. That is, I pass the name of the group to a function and it returns the names of the blocks of the group itself
2-Selecting a block I would like to know the name of the group it belongs to, if it exists.
Thanks to everyone for the help
grifo

rlx Grand Master

rlx

Posted
Posted (edited)

Welcome to cadtutor grifo!

 

here is something I dug up from my archives , maybe it contains something you can play with.

  

(defun c:getG ( / gr g)
  (vl-load-com)
  (setq gr (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for g gr
    (princ (strcat "\nGroup : " (vla-get-name g)))
    (vlax-dump-object g)
    (princ)
  )
)

(defun getGroup (eName / eData grpData)
  (if (and (setq eData (entget eName))
	   (setq grpData (assoc 330 eData))
	   (setq grpData (entget (cdr grpData)))
	   (eq (cdr (assoc 0 grpData)) "GROUP"))
    grpData))

(defun RemoveFromGroup (eName / grpData grpObject eObject items)
  (vl-load-com)
  (if (setq grpData (getGroup eName))
    (progn
      (setq eObject (vlax-ename->vla-object eName)
	    grpObject (vlax-ename->vla-object (cdar grpData))
	    items (vlax-make-safearray vlax-vbObject '(0 . 0)))
      (vlax-safearray-put-element items 0 eObject)
      (vla-RemoveItems grpObject (vlax-make-variant items)))))

(defun c:T1 (/ e gr)
  (if (setq e (entsel))
    (if (setq gr (getGroup (car e)))
      (princ (strcat "\nGroup = " gr))))
  (princ))

(defun c:T2 (/ e)
  (if (setq e (entsel))
    (RemoveFromGroup (car e)))
  (princ))

; GetObjGroupNames
 ; Return the list of names of groups of object or nil.
 ; Arguments [Type]:
 ; Obj = Object [VLA-OBJECT or ENAME]
 ; Return [Type]:
 ; The list of names of groups

 (defun	GetObjGroupNames (Obj / Cur_ID NmeLst)
   (or *activedoc*
       (setq *activedoc* (vla-get-activedocument (vlax-get-acad-object)))
   )
   (if (= (type Obj) 'ENAME)
     (setq Obj (vlax-ename->vla-object Obj))
   )
   (setq Cur_ID (vla-get-ObjectID Obj))
   (vlax-for Grp (vla-get-Groups *activedoc*)
     (vlax-for Ent Grp
       (if (equal (vla-get-ObjectID Ent) Cur_ID)
	 (setq NmeLst (cons (vla-get-Name Grp) NmeLst))
       )
       (vlax-release-object Ent)
     )
     (vlax-release-object Grp)
   )
   (reverse NmeLst)
 )


(defun c:t3 ( / *activedoc* e grps)
  (vl-load-com)
  (if (setq e (entsel))
    (if (setq grps (GetObjGroupNames (car e)))
      (mapcar '(lambda (x) (princ (strcat "\nGroup = " x))) grps)))
  (princ)
)

(defun Append2Group (group_name selection / active_document selection)
  (vl-load-com)
  (setq active_document (vla-get-activedocument (vlax-get-acad-object)))
  (if selection
    (if	(not (vl-catch-all-error-p
	       (setq known_group
		      (vl-catch-all-apply
			'vla-item
			(list (vla-get-groups
				active_document
			      )
			      group_name
			)
		      )
	       )
	     )
	)
      (if (not (vl-catch-all-error-p
		 (vl-catch-all-apply
		   'vla-appenditems
		   (list known_group
			 (vlax-safearray-fill
			   (vlax-make-safearray
			     vlax-vbobject
			     (cons 0 (1- (sslength selection)))
			   )
			   (mapcar 'vlax-ename->vla-object
				   (vl-remove-if-not
				     (function (lambda (x)
						 (= (type x) 'ename)
					       )
				     )
				     (mapcar 'cadr
					     (ssnamex
					       selection
					     )
				     )
				   )
			   )
			 )
		   )
		 )
	       )
	  )
	T
	(prompt "\nAppend failed.\n")
      )
      (prompt "\nNo such group.\n")
    )
    (prompt "\nNothing to append.\n")
  )
)

(defun c:t6 ( / blk grp)
  (setq grp (car (entsel "\nSelect group to add block to ")))
  (princ "\nSelect block to add to selected group ")
  (setq blk (ssget ))
  (if (and (setq grp (ALE_GetGroupNames grp)) blk)
    (Append2Group (car grp) blk)))

;;;-----------------------------------------------------------------------------------------------------------
;http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-routine-to-get-quot-group-name-quot/m-p/1413137/highlight/true#M188785
(defun C:GetGroupName (/ CurEnt GrpLst)
  (if (setq CurEnt (car (entsel)))
    (if	(setq GrpLst (MeGetGroupName CurEnt))
      (alert
	(strcat
	  "The selected object is member of group(s):"
	  (apply
	    'strcat
	    (mapcar '(lambda (l) (strcat "\n- " l)) GrpLst)
	  )
	)
      )
      (alert "The selected object is not member of a group.")
    )
  )
  (princ)
)


 (defun	MeGetGroupName (Ent / CurDct CurGps)
   (setq CurDct	(dictsearch (namedobjdict) "ACAD_GROUP")
	 CurGps	(cdar CurDct)
   )
   (apply 'append
	  (mapcar
	    '(lambda (l)
	       (if (member Ent (MeGetSubLst 340 (dictsearch CurGps l)))
		 (list l)
	       )
	     )
	    (MeGetSubLst 3 CurDct)
	  )
   )
 )


 (defun	MeGetSubLst (Key Lst)
   (mapcar
     'cdr
     (vl-remove-if-not
       '(lambda (l) (equal (car l) Key))
       Lst
     )
   )
 )
;--------------------------------------------------------------------------------------------------------------


;http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-group-name-of-an-entity/td-p/1526241/highlight/true/page/5
; Marc'Antonio Alessi, Italy - http://xoomer.virgilio.it/alessi
 ;
 ; Credits: Tony Tanzillo
 ;
 ; Function: ALE_GetGroupNames
 ;
 ; Version 1.05 - 14/01/2006
 ;
 ; Description:
 ; returns a list of all the groups names of which EntNam is member
 ;
 ; Arguments:
 ; EntNam: Entity name [ENAME]
 ;
 ; Example:
 ; (ALE_GetGroupNames (entlast))
 ;
 (defun	ALE_GetGroupNames (EntNam / EntDat VlaObj OutLst)
   (if (setq EntDat (member '(102 . "{ACAD_REACTORS") (entget EntNam)))
     (while
       (and
	 (setq EntDat (cdr EntDat))
	 (eq (caar EntDat) 330)
	 (eq
	   (vla-get-ObjectName
	     (setq VlaObj (vlax-ename->vla-object (cdar EntDat)))
	   )
	   "AcDbGroup"
	 )
       )
	(if (equal (cadr EntDat) '(102 . "}"))
	  (setq EntDat nil)
	)
	(setq OutLst (cons (vla-get-Name VlaObj) OutLst))
     )
   )
 )
(defun c:t5 ()
  (ALE_GetGroupNames (car (entsel))))

 

Edited by rlx
grifo Newbie

grifo

Posted
  • Author
Posted

Hi Rlx,
thanks a lot for the answer
I tried some of your functions:
getG > displays the group information (name, number of components, etc.)
T3 > returns the name of the group that that block belongs to [interesting]
other functions return the name of the group
while other functions I have to test them.
The only thing missing is knowing the name of the blocks that make up a group given its name
Thanks
Grifo

rlx Grand Master

rlx

Posted
Posted

here's something to list all block names that live in a group

  

;;; blocks in group
(defun c:big ( / gl ) (vl-load-com)
  (if (not (vl-consp (setq gl (lag))))
    (alert "Computer says no : there are no groups")
    ;;; show all blocks in group (choose from group list)
    (sabig (cfl gl))
  )
  (princ)
)

;;; list all groups (setq rtn (lag))
(defun lag ( / gps lst)
  (setq gps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for g gps (setq lst (cons (vla-get-name g) lst)))
  (if (vl-consp lst) (acad_strlsort lst))
)

; choose from list (cfl '("1""2""3"))
(defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
 (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p)
  (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
   (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
    (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)")
     (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

;;; display list (plus message)
(defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";"
   "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb")
     (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f))))



; multiple association
(defun massoc ($i $l / a l)(while (setq a (assoc $i $l))(setq l (cons (cdr a) l) $l (cdr (member a $l))) l))


;;; test if (vla) object is a block / get blockname / ename->vla-object
(defun block-p (o) (and (setq o (e->o o)) (member (vla-get-objectname o) '("AcDbBlockReference" "AcDbBlockTableRecord"))))
(defun block-n (o) (if (block-p o)(if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o))))
(defun e->o    (e) (cond ((= 'vla-object (type e)) e)((= 'ename (type e))(vlax-ename->vla-object e))(t nil)))

;;; show all blocks in group
(defun sabig (gname / odic gdic grec el blist)
  (setq odic (namedobjdict))
  (setq gdic (dictsearch odic "ACAD_GROUP"))
  (setq grec (dictsearch (cdar gdic) gname))
  (setq el (massoc 340 grec))
  (if (vl-consp el)
    (foreach x el (if (block-p x)(setq blist (cons (block-n (e->o x)) blist)))))
  (if (vl-consp blist)
    (dplm (acad_strlsort blist) (strcat "Blocks in group " gname))
    (alert (strcat "Computer says no : sorry no block in group " gname))
  )
)

 

🐉

 

  • Like 2
grifo Newbie

grifo

Posted
  • Author
Posted

Hi Rlx,
Awesome !!!!
I wanted to take advantage of your kindness to ask you one last favor.
is it possible to generate a text file that contains the list of block names like:
file1.txt
block name1
block name2
block name3
.
instead of highlighting their name on a menu?
thank you in advance for your help
Best regards
Grifo

rlx Grand Master

rlx

Posted
Posted 
;;; blocks in group
(defun c:big ( / gl ) (vl-load-com)
  (if (not (vl-consp (setq gl (lag))))
    (alert "Computer says no : there are no groups")
    ;;; show all blocks in group (choose from group list)
    (sabig (cfl gl))
  )
  (princ)
)

;;; list all groups (setq rtn (lag))
(defun lag ( / gps lst)
  (setq gps (vla-get-groups (vla-get-activedocument (vlax-get-acad-object))))
  (vlax-for g gps (setq lst (cons (vla-get-name g) lst)))
  (if (vl-consp lst) (acad_strlsort lst))
)

; choose from list (cfl '("1""2""3"))
(defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
 (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p)
  (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
   (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
    (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)")
     (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

;;; display list (plus message)
(defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";"
   "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb")
     (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f))))



; multiple association
(defun massoc ($i $l / a l)(while (setq a (assoc $i $l))(setq l (cons (cdr a) l) $l (cdr (member a $l))) l))


;;; test if (vla) object is a block / get blockname / ename->vla-object
(defun block-p (o) (and (setq o (e->o o)) (member (vla-get-objectname o) '("AcDbBlockReference" "AcDbBlockTableRecord"))))
(defun block-n (o) (if (block-p o)(if (vlax-property-available-p o 'EffectiveName)(vla-Get-EffectiveName o)(vla-Get-Name o))))
(defun e->o    (e) (cond ((= 'vla-object (type e)) e)((= 'ename (type e))(vlax-ename->vla-object e))(t nil)))

;;; show all blocks in group
(defun sabig (gname / odic gdic grec el blist)
  (setq odic (namedobjdict))
  (setq gdic (dictsearch odic "ACAD_GROUP"))
  (setq grec (dictsearch (cdar gdic) gname))
  (setq el (massoc 340 grec))
  (if (vl-consp el)
    (foreach x el (if (block-p x)(setq blist (cons (block-n (e->o x)) blist)))))
  (if (vl-consp blist)
    ;;; (dplm (acad_strlsort blist) (strcat "Blocks in group " gname))
    (write-list blist)
    (alert (strcat "Computer says no : sorry no block in group " gname))
  )
)

(defun write-list ( l / fn fp)
  (if (setq fp (open (setq fn (strcat (getvar "dwgprefix") "file1.txt")) "w"))
    (progn
      (foreach item l (write-line item fp))
      (close fp) (gc) (gc) (startapp "notepad" fn)
    )
  )
  (princ)
)

 

voila.jpg.ee1749cd4a5a9df0bdd5d8c544b3cfa0.jpg

  • Like 3
grifo Newbie

grifo

Posted
  • Author
Posted

Hi Rlx,
Thanks to you everything is perfect!!!!
Thanks so much for your help, I would never have gotten there alone
Thanks a thousand
Grifo

grifo Newbie

grifo

Posted
  • Author
Posted

Hi,
Regarding groups I have another small problem due to my poor knowledge of lisp..this function "GetObjGroupNames" works perfectly, only that it returns me as a value > ("GroupName") and I would need it to return only a string "GroupName" Thanks for your kind collaboration
Grifo

#

(defun    GetObjGroupNames (Obj / Cur_ID NmeLst)
   (or *activedoc*
       (setq *activedoc* (vla-get-activedocument (vlax-get-acad-object))) )
   (if (= (type Obj) 'ENAME)
     (setq Obj (vlax-ename->vla-object Obj)))
   (setq Cur_ID (vla-get-ObjectID Obj))
   (vlax-for Grp (vla-get-Groups *activedoc*)
     (vlax-for Ent Grp
       (if (equal (vla-get-ObjectID Ent) Cur_ID)
     (setq NmeLst (cons (vla-get-Name Grp) NmeLst)))
       (vlax-release-object Ent))
     (vlax-release-object Grp))
   (reverse NmeLst)) 
 

rlx Grand Master

rlx

Posted
Posted

Your return is a list , in your example this is a list with one member '("GroupName")

to retrieve it is very basic lisp :

(setq group-list '("GroupName"))

(setq group-name (car group-list)) or (setq group-name (nth 0 group-list))

  • Like 1
grifo Newbie

grifo

Posted
  • Author
Posted

Thanks 1000 Rlx
Grifo

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.

×
 Share
Go to topic listing
×
×
  • Create New...