(defun c:bt (/ libloc liidbloc ss ss liref ptins tableVL cont)

;;; (prompt "\nSelect Blocks to list ")
;;;
;;; (setq ssu (ssget '((0 . "INSERT"))))
;;;
;;; (setq sst (ssget "_X" '((0 . "INSERT"))))

(vl-load-com)

(or *acad* (setq *acad* (vlax-get-acad-object)))

(initget "Select All Objects")

(setq kw

(getkword

"\nSelect blocks by [Object/All/Select] : "

)

)

(cond

((= kw "Objet")

(and

(setq ent

(car (entsel "\nSelect Circle Ellipse or Polyline: ")

)

)

(setq typ (cdr (assoc 0 (entget ent))))

(or (member typ '("CIRCLE" "ELLIPSE"))

(and (= typ "LWPOLYLINE")

(= 1 (logand 1 (cdr (assoc 70 (entget ent)))))

)

)

(setq ss (SelByObj ent "Wp" '((0 . "INSERT"))))

)

)

((= kw "Tous") (setq ss (ssget "_X" '((0 . "INSERT")))))

(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 ss

(setq libloc (remove_doubles

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

)

)

liidbloc (mapcar

'(lambda (x)

(vla-get-ObjectID

(vla-item

(vla-get-Blocks

(vla-get-activedocument

(vlax-get-acad-object)

)

)

x

)

)

)

libloc

)

liref (vl-remove-if-not '(lambda (n) (member n libloc)) liref)

)

(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 ptins (getpoint "\nSelect Block Table Insertion Point: "))

(vl-load-com)

(setq tableVL (vla-addtable

(vla-get-modelspace

(vla-get-activedocument (vlax-get-acad-object))

)

(vlax-3d-point ptins)

(1+(length libloc) )

3

20

100

)

)

(vla-put-TitleSuppressed tableVL :vlax-true)
(vla-put-HeaderSuppressed tableVL :vlax-true)

(setq cont -1)

(repeat (1-(vla-get-Rows tableVL) )

(vla-settext

tableVL

(1+(setq cont (1+ cont)) )

0

(nth cont libloc)

)

(vla-settext

tableVL

(1+ cont )

1

(length (vl-remove-if-not

'(lambda (n) (= n (nth cont libloc)))

liref

)

)

)

(vla-SetBlockTableRecordId

tableVL

(1+ cont )

2

(nth cont liidbloc)

:vlax-true

)

(vla-setcellalignment tableVL cont 0 5)

(vla-setcellalignment tableVL cont 1 5)

)

(princ)

)

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

(defun REMOVE_DOUBLES (lst)

(cond

((atom lst) lst)

(T

(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 un objet (cercle, ellipse, polyligne fermיe)

;;; Arguments :

;;; - ent : un objet (ename ou vla-object)

;;; - opt : un mode de sיlection (Cp ou Wp)

;;; - fltr : un filtre de sיlection (liste) ou nil

;;;

;;; modifiי le 26/07/07 : fonctionne avec les objets hors fenךtre

(defun SelByObj (ent opt fltr / obj dist n lst prec dist p_lst ss)

(if (= (type ent) 'ENAME)

(setq obj (vlax-ename->vla-object ent))

(setq obj ent

ent (vlax-vla-object->ename ent)

)

)

(cond

((member (vla-get-ObjectName obj) '("AcDbCircle" "AcDbEllipse"))

(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

)

)

)

)

((and (= (vla-get-ObjectName obj) "AcDbPolyline")

(= (vla-get-Closed obj) :vlax-true)

)

(setq p_lst (vl-remove-if-not

(function

(lambda (x)

(or (= (car x) 10)

(= (car x) 42)

)

)

)

(entget ent)

)

)

(while p_lst

(setq

lst

(cons

(trans (append (cdr (assoc 10 p_lst))

(list (cdr (assoc 38 (entget ent))))

)

ent

1

)

lst

)

)

(if (/= 0 (cdadr p_lst))

(progn

(setq prec (1+ (fix (* 25 (sqrt (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 (cons

(trans

(vlax-curve-getPointAtDist

obj

(+ (vlax-curve-getDistAtPoint

obj

(trans (cdar p_lst) ent 0)

)

(* dist (setq n (1+ n)))

)

)

0

1

)

lst

)

)

)

)

)

(setq p_lst (cddr p_lst))

)

)

)

(cond

(lst

(vla-ZoomExtents *acad*)

(setq ss (ssget (strcat "_" opt) lst fltr))

(vla-ZoomPrevious *acad*)

ss

)

)

)

(c:bt)

Advertisements