CALCULER LE NB DE BLOCS

[PHILPHIL]

BONJOUR

 

vous avez un tit LISP qui calcule le NB de blocs et qui marche sous autocad 2008

 

ceux que j'ai ne marchent plus

 

merci

 

phil

[lili2006]

Bonjour à tous,

 

Je ne sais pas si c'est ce que tu cherches,mais moi, personnellement, j'aime bien ce lisp de (gile) : "tabloc"

 

 (defun c:tabloc (/ kw libloc liidbloc ss col liref ptins tableVL cont)
(vl-load-com)
(initget "Collection Objet Sélection")
(setq kw (getkword "\nChoisir une option [Collection/Objet/Sélection] : "))
(cond
((= kw "Objet")
(if
(setq
obj
(car
(entsel "\nSélectionnez l'objet délimitant la sélection: ")
)
)
(if (member (cdr (assoc 0 (entget obj)))
'("CIRCLE" "ELLIPSE" "LWPOLYLINE")
)
(setq ss (SelByObj obj "WP" '((0 . "INSERT"))))
(princ "\nEntité non valide.")
)
(princ "\nAucune entité sélectionnée.")
)
)
((= kw "Collection")
(setq ss (ssget "_X" '((0 . "INSERT")))
col T
)
)
(T (setq ss (ssget '((0 . "INSERT")))))
)
(if ss
(setq liref
(mapcar '(lambda (x)
(setq x (vlax-ename->vla-object x))
(if (vlax-property-available-p x 'EffectiveName)
(vla-get-EffectiveName x)
(vla-get-Name x)
)
)
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setq liref '())
)
(if col
(vlax-for i (vla-get-Blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(if (and (/= (substr (vla-get-name i) 1 1) "*")
(= :vlax-false (vla-get-IsXref i))
)
(setq libloc (append libloc (list (vla-get-name i)))
liidbloc (append liidbloc (list (vla-get-ObjectID i)))
)
)
)
(setq libloc (remove_doubles liref)
liidbloc (mapcar
'(lambda (x)
(vla-get-ObjectID
(vla-item
(vla-get-Blocks
(vla-get-activedocument
(vlax-get-acad-object)
)
)
x
)
)
)
libloc
)
)
)
(initget 1)
(setq ptins (trans (getpoint "\nPoint d'insertion: ") 1 0))
(setq tableVL (vla-addtable
(vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
(vlax-3d-point ptins)
(+ (length libloc) 2)
3
20
100
)
)
(vla-put-TitleSuppressed tableVL :vlax-false)
(vla-setText tableVL 0 0 "LEGENDE/QUANTITATIF")
(mapcar '(lambda (x)
(vla-setText tableVL 1 (car x) (cdr x)))
'((0 . "SYMBOLE") (1 . "DESIGNATION") (2 . "QUANTITE"))
)
(setq cont 0)
(repeat (vla-get-Rows tableVL)
(vla-SetBlockTableRecordId
tableVL
(1+ (setq cont (1+ cont)))
0
(nth (1- cont) liidbloc)
:vlax-true
)
(vla-settext
tableVL
(1+ cont)
1
(nth (1- cont) libloc)
)
(vla-settext
tableVL
(1+ cont)
2
(length (vl-remove-if-not
'(lambda (n) (= n (nth (1- cont) libloc)))
liref
)
)
)
(vla-setcellalignment tableVL (1+ cont) 1 5)
(vla-setcellalignment tableVL (1+ cont) 2 5)
)
(princ)
)

;;; REMOVE_DOUBLES - Suprime tous les doublons d'une liste

(defun remove_doubles (lst)
(if lst
(cons (car lst) (remove_doubles (vl-remove (car lst) lst)))
)
)

;;; SelByObj -Gilles Chanteau- 06/10/06
;;; Crée un jeu de sélection avec tous les objets contenus ou
;;; capturés, dans la vue courante, par l'objet sélectionné
;;; (cercle, ellipse, polyligne fermée).
;;; Arguments :
;;; - un nom d'entité (ename)
;;; - un mode de sélection (Cp ou Wp)
;;; - un filtre de sélection ou nil

(defun SelByObj (ent opt fltr / obj dist n lst prec dist p_lst)
(vl-load-com)
(setq obj (vlax-ename->vla-object ent))
(cond
((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ELLIPSE"))
(setq dist (/ (vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
50
)
n 0
)
(repeat 50
(setq
lst
(cons
(trans
(vlax-curve-getPointAtDist obj (* dist (setq n (1+ n))))
0
1
)
lst
)
)
)
)
(T
(setq p_lst (vl-remove-if-not
'(lambda (x)
(or (= (car x) 10)
(= (car x) 42)
)
)
(entget ent)
)
)
(while p_lst
(setq
lst (append
lst
(list (trans (append (cdr (assoc 10 p_lst))
(list (cdr (assoc 38 (entget ent))))
)
ent
1
)
)
)
)
(if (/= 0 (cdadr p_lst))
(progn
(setq prec (1+ (fix (* 50 (abs (cdadr p_lst)))))
dist (/ (- (if (cdaddr p_lst)
(vlax-curve-getDistAtPoint
obj
(trans (cdaddr p_lst) ent 0)
)
(vlax-curve-getDistAtParam
obj
(vlax-curve-getEndParam obj)
)
)
(vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
)
prec
)
n 0
)
(repeat (1- prec)
(setq
lst (append
lst
(list
(trans
(vlax-curve-getPointAtDist
obj
(+ (vlax-curve-getDistAtPoint
obj
(trans (cdar p_lst) ent 0)
)
(* dist (setq n (1+ n)))
)
)
0
1
)
)
)
)
)
)
)
(setq p_lst (cddr p_lst))
)
)
)
(ssget (strcat "_" opt) lst fltr)
)

En espérant que cela puisse t'aider,..