;;;=================================================================
;;;
;;; LSTATT.LSP V4.40
;;;
;;; Décompte des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:lstatt(/ choix doc i js ent fic fil lab lst mrc trc n nb nm nombl InputBox liste_att mrech rechercher_nom s sel tbl trier txt visibilite *errlst*)

  (defun *errlst* (msg)
    (or (member (strcase msg) '("FUNCTION CANCELLED" ""QUIT / EXIT ABORT"" "FONCTION ANNULEE" "QUITTER / SORTIR ABANDON"))
      (princ (strcat "\nErreur : " msg))
    )
    (setq *error* s)
    (princ)
  )

  (defun visibilite(nom / bl ok vi)
    (and (setq bl (vla-item (vla-get-blocks doc) nom))
	 (setq vi (vl-some '(lambda (pair)
			     (if
				(and
				  (= 360 (car pair))
				  (= "BLOCKVISIBILITYPARAMETER" (cdr (assoc 0 (entget (cdr pair)))))
				)
				(cdr pair)
			      )
			    )
			    (dictsearch (vlax-vla-object->ename (vla-getextensiondictionary bl)) "ACAD_ENHANCEDBLOCK")
		  )
	 )
	 (setq vi (entget vi))
	 (setq ok (cdr (assoc 301 vi)))
    )
    ok
  )

  (defun nombl(bl / nom vi)
    (if (vlax-property-available-p bl 'effectivename)
      (progn
	(setq nom (vla-get-effectivename bl))
	(and (setq vi (visibilite nom))
	     (= (vla-get-propertyname (car (vlax-invoke bl 'getdynamicblockproperties))) vi)
	     (setq nom (strcat nom ":" (vlax-get (car (vlax-invoke bl 'getdynamicblockproperties)) 'value)))
	)
	nom
      )
      (vla-get-name bl)
    )
  )

  (defun choix(/ bl js lst nom sel)
    (princ "\nSélectionnez le(s) bloc(s) à dénombrer : ")
    (and (ssget (list (cons 0 "insert")))
      (progn
	(vlax-for bl (setq sel (vla-get-activeselectionset doc))
	  (or (member (setq nom (nombl bl)) lst)
	    (setq lst (cons nom lst))
	  )
	  (redraw (vlax-vla-object->ename bl) 4)
	)
	(foreach nom lst
	  (if js
	    (setq js (strcat js "," nom))
	    (setq js nom)
	  )
	)
	(vla-delete sel)
      )
    )
    js
  )

  (defun InputBox (Titre js / ch dcl fil res tmp txt)
    (setq tmp (vl-filename-mktemp "lstatt" nil ".dcl")
	  fil (open tmp "w")
    )
    (foreach txt '(	"lstatt : dialog {"
			"  key = \"titre\";"
			"  alignment = centered;"
			"  is_cancel = true;"
			"  allow_accept = true;"
			"  width = 30;"
			"  : boxed_column {"
			"    label = \"Veuillez donner un nom de bloc ou * pour tous\";"
			"    : row {"
			"      : edit_box {key = \"filtre\";width = 45;}"
			"      : button {key = \"choix\"; label = \">>\";}"
			"    }"
			"    spacer;"
			"  }"
			"  : boxed_column {"
			"    label = \"Nombre d'attributs à prendre en compte\"; "
			"    : edit_box {key= \"att\";}"
			"    spacer;"
			"  }"
			"  spacer;"
			"  : toggle {key = \"fic\"; label = \"Ecrire les résultats dans un fichier\";}"
			"  : toggle {key = \"lab\"; label = \"Ajouter le nom des étiquettes dans les résultats\";}"
			"  spacer;"
			"  ok_cancel;"
			"}"
		 )
      (write-line txt fil)
    )
    (close fil)
    (setq dcl (load_dialog tmp))
    (while (not (member res '(0 1)))
      (new_dialog "lstatt" dcl "")
      (set_tile "titre" titre)
      (set_tile "filtre" js)
      (set_tile "att" nb)
      (set_tile "fic" fic)
      (set_tile "lab" lab)
      (action_tile "filtre" "(setq js $value)")
      (action_tile "choix"  "(done_dialog 2)")
      (action_tile "att"    "(setq nb $value)")
      (action_tile "fic"    "(setq fic $value)")
      (action_tile "lab"    "(setq lab $value)")
      (action_tile "accept" "(done_dialog 1)")
      (action_tile "cancel" "(done_dialog 0)")
      (setq res (start_dialog))
      (and (eq res 2)
	   (setq ch (choix))
	   (setq js ch)
      )
    )
    (unload_dialog dcl)
    (vl-file-delete tmp)
    (if (member res '(1 2))
      js
      ""
    )
  )

  (defun liste_att(att / n lst val)
    (if (< (atoi nb) (length att))
      (progn
	(setq n 0)
	(while (and (< n (atoi nb)) (setq val (nth n att)))
	  (setq lst (cons (if (eq lab "0")
			    (vla-get-textstring (nth n att))
			    (strcat (vla-get-tagstring (nth n att)) ":" (vla-get-textstring (nth n att)))
			  )
			  lst
		    )
		n (1+ n)
	  )
	)
	(reverse lst)
      )
      (if (eq lab "0")
        (mapcar 'vla-get-textstring att)
	(mapcar '(lambda(x)(strcat (vla-get-tagstring x) ":" (vla-get-textstring x))) att)
      )
    )
  )

  (defun rechercher_nom(val / att nom tbl)
    (setq nom (nombl val))
    (if (eq (vla-get-hasattributes val) :vlax-true)
      (if (member (setq att (vlax-invoke val 'getattributes)) '(nil))
	(list nom)
	(cons nom (liste_att att))
      )
      (list nom)
    )
  )

  (defun trier(a b / c n s)
    (setq c 0)
    (while (and (not s) (nth c a))
      (if (eq (nth c a) (nth c b))
	(setq c (1+ c))
	(setq s T)
      )
    )
    (or (nth c a) (setq c 0))
    (< (strcase (nth c a)) (strcase (nth c b)))
  )

  (defun mrech(bl / ent lst recu)
    (defun recu(bl)
      (vlax-for ent (vla-item (vla-get-blocks doc) (nombl bl))
	(and (eq (vla-get-objectname ent) "AcDbBlockReference")
	  (if (eq (substr (nombl ent) 1 1) "*")
	    (recu ent)
	    (setq lst (cons ent lst))
	  )
	)
      )
    )
    (and (eq (substr (nombl bl) 1 1) "*")
      (recu bl)
    )
    lst
  )

  (vl-load-com)
  (setq s *error*
	*error* *errlst*
	doc (vla-get-activedocument (vlax-get-acad-object))
  )
  (or (setq nb (getenv "Patrick_35_nb_att"))
    (setq nb "1")
  )
  (or (setq lab (getenv "Patrick_35_nb_lab"))
    (setq lab "0")
  )
  (setq fic "0")
  (if (not (eq (setq nm (InputBox "Décompte de blocs V4.40" "*")) ""))
    (progn
      (setq js (strcat "`**," nm))
      (if (ssget (list (cons 0 "INSERT") (cons 2 js)))
	(progn
	  (setenv "Patrick_35_nb_att" nb)
	  (setenv "Patrick_35_nb_lab" lab)
	  (vlax-map-collection	(setq sel (vla-get-activeselectionset doc))
				'(lambda (x)
				  (if (setq trc (mrech x))
				    (foreach mrc trc
				      (if (wcmatch (strcase (car (setq js (rechercher_nom mrc)))) (strcase nm))
					(setq tbl (cons js tbl))
				      )
				    )
				    (if (wcmatch (strcase (car (setq js (rechercher_nom x)))) (strcase nm))
				      (if (eq (vla-get-objectname x) "AcDbMInsertBlock")
					(repeat (* (vla-get-columns x) (vla-get-rows x))
					  (setq tbl (cons js tbl))
					)
					(setq tbl (cons js tbl))
				      )
				    )
				  )
				)
	  )
	  (vla-delete sel)
	  (while tbl	
	    (setq n   (length tbl)
		  js  (car tbl)
		  tbl (vl-remove js tbl)
		  lst (cons (cons (itoa (- n (length tbl))) js) lst)
	    )
	  )
	  (if lst
	    (progn
	      (and (eq fic "1")
		(setq fil (open (setq txt (strcat (getvar "dwgprefix") (vl-filename-base (getvar "dwgname")) ".txt")) "w"))
	      )
	      (foreach n (vl-sort lst '(lambda (a b) (trier (cdr a) (cdr b))))
		(if (eq fic "1")
		  (princ (strcat (car n) (chr 9) (cadr n)) fil)
		  (princ (strcat "\n"
				 (substr "     " 1 (- 5 (strlen (car n))))
				 (car n)
				 " "
				 (cadr n)
			 )
		  )
		)
		(setq i 2)
		(while (setq val (nth i n))
		  (if (eq fic "1")
		    (princ (strcat (chr 9) val) fil)
		    (princ (strcat "..." val))
		  )
		  (setq i (1+ i))
		)
		(and (eq fic "1")
		  (write-line "" fil)
		)
	      )
	      (and (eq fic "1")
		(princ (strcat "\nFichier \"" txt "\" créé."))
		(close fil)
	      )
	    )
	    (princ "\nPas de bloc à dénombrer.")
	  )
	)
      )
    )
  )
  (setq *error* s)
  (princ)
)

(setq nom_lisp "LSTATT")
(if (/= app nil)
  (if (= (strcase (substr app (1+ (- (strlen app) (strlen nom_lisp))) (strlen nom_lisp))) nom_lisp)
    (princ (strcat "..." nom_lisp " chargé."))
    (princ (strcat "\n" nom_lisp ".LSP Chargé.....Tapez " nom_lisp " pour l'éxecuter.")))
  (princ (strcat "\n" nom_lisp ".LSP Chargé......Tapez " nom_lisp " pour l'éxecuter.")))
(setq nom_lisp nil)
(princ)