transformer des points en blocs

[mimine]

Bonsoir, je doit transformer des points en blocs, j'ai trouvé ce lisp mais il ne fonctionne pas sur lla totalité de mon dessin "Trop d'objets sélectionnés pour INTERSECT" (1235 points ).

Et si je sélectionne par zone il me rajoute des blocs ou il n'y a pas de point.

Je suis nul en lisp, quelqu'un pourrait'il m'aidée

 

merci beaucoup

 

 

(defun c:pnt2blk (/ ss ct len e eb bname lay pt attreqhold echohold)

 

;;;get command echo setting and store it

(setq echohold (getvar "CMDECHO"))

 

;;;set command echo off

(setvar "CMDECHO" 0)

 

;;;get attribute request setting and store it

(setq attreqhold (getvar "ATTREQ"))

 

;;;set attribute request off

(setvar "ATTREQ" 0)

 

;;;get name of block to insert

(setq bname (getstring "\nBlock name: "))

 

;;;check that the block is defined in the current drawing

(if (tblsearch "block" bname)

(progn

 

(if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 bname))))

(setq lay (cdr (assoc 8 (entget (ssname ss 0)))))

)

 

;;;prompt for point selection

(princ "\nSelect point objects:")

 

;;;if point objects were selected

(if (setq ss (ssget '((0 . "POINT"))))

(progn

 

;;;walk through point objects

(setq len (sslength ss))

(setq ct 0)

(while (< ct len)

 

;;;for each point

(setq e (ssname ss ct))

(setq ct (+ ct 1))

(setq eb (entget e))

;;;get insert point

(setq pt (cdr (assoc 10 eb)))

;;;insert block

(command "_insert" bname pt "" "" "")

 

(if lay

(command "_chprop" (entlast) "" "_Layer" lay "")

)

 

)

)

(princ "\nNo point objects selected.")

)

)

(princ "\nInvalid, block not defined in drawing.")

)

 

;;;restore command echo setting to stored value

(setvar "CMDECHO" echohold)

 

;;;restore attribute request setting to stored value

(setvar "ATTREQ" 0)

 

(princ)

)

[(gile)]

Salut,

 

Tu peux essayer ça :

 

;; PT2BLK
;; Remplace tous les points sélectionnés par le bloc spécifié

(defun c:pt2blk	(/ bl ss)
 (or *acdoc*
     (setq *acdoc* (vla-get-Activedocument (vlax-get-acad-object)))
 )
 (and
   (setq bl (getblock nil))
   (princ "\nSélectionnez les points ou [b]: ")
   (or	(ssget '((0 . "POINT")))
(ssget "_X" '((0 . "POINT")))
   )
   (not (vla-StartUndoMark *acdoc*))
   (vlax-for p	(vla-get-ActiveSelectionSet *acdoc*)
     (vla-insertBlock
(vla-get-ModelSpace *acdoc*)
(vla-get-Coordinates p)
bl
1
1
1
0
(vla-delete p)
     )
   )
   (vla-EndUndoMark *acdoc*)
 )
 (princ)
)

;;; Getblock (gile) 03/11/07
;;; Retourne le nom du bloc entré ou choisi par l'utilisateur 
;;; dans une liste déroulante de la boite de dialogue ou depuis la boite
;;; de dialogue standard d'AutoCAD
;;; Argument : le titre (string) ou nil (défaut : "Choisir un bloc")

(defun getblock	(titre / bloc n lst tmp file what_next dcl_id nom)
 (while (setq bloc (tblnext "BLOCK" (not bloc)))
   (setq lst (cons (cdr (assoc 2 bloc)) lst)
   )
 )
 (setq	lst  (acad_strlsort
       (vl-remove-if
	 (function (lambda (n) (= (substr n 1 1) "*")))
	 lst
       )
     )
tmp  (vl-filename-mktemp "Tmp.dcl")
file (open tmp "w")
 )
 (write-line
   (strcat
     "getblock:dialog{label="
     (cond (titre (vl-prin1-to-string titre))
    ("\"Choisir un bloc\"")
     )
     ";initial_focus=\"bl\";:boxed_column{
     :row{:text{label=\"Sélectionner\";alignment=left;}
     :button{label=\">>\";key=\"sel\";alignment=right;fixed_width=true;}}
     spacer;
     :column{:button{label=\"Parcourir...\";key=\"wbl\";alignment=right;fixed_width=true;}}
     :column{:text{label=\"Nom :\";alignment=left;}}
     :edit_box{key=\"tp\";edit_width=25;}
     :popup_list{key=\"bl\";edit_width=25;}spacer;}
     spacer;
     ok_cancel;}"
   )
   file
 )
 (close file)
 (setq dcl_id (load_dialog tmp))
 (setq what_next 2)
 (while (>= what_next 2)
   (if	(not (new_dialog "getblock" dcl_id))
     (exit)
   )
   (start_list "bl")
   (mapcar 'add_list lst)
   (end_list)
   (if	(setq n	(vl-position
	  (strcase (getvar "INSNAME"))
	  (mapcar 'strcase lst)
	)
)
     (setq nom (nth n lst))
     (setq nom	(car lst)
    n	0
     )
   )
   (set_tile "bl" (itoa n))
   (action_tile "sel" "(done_dialog 5)")
   (action_tile "bl" "(setq nom (nth (atoi $value) lst))")
   (action_tile "wbl" "(done_dialog 3)")
   (action_tile "tp" "(setq nom $value) (done_dialog 4)")
   (action_tile
     "accept"
     "(setq nom (nth (atoi (get_tile \"bl\")) lst)) (done_dialog 1)"
   )
   (setq what_next (start_dialog))
   (cond
     ((= what_next 3)
      (if (setq nom (getfiled "Sélectionner un fichier" "" "dwg" 0))
 (setq what_next 1)
 (setq what_next 2)
      )
     )
     ((= what_next 4)
      (cond
 ((not (read nom))
  (setq what_next 2)
 )
 ((tblsearch "BLOCK" nom)
  (setq what_next 1)
 )
 ((findfile (setq nom (strcat nom ".dwg")))
  (setq what_next 1)
 )
 (T
  (alert (strcat "Le fichier \"" nom "\" est introuvable."))
  (setq	nom nil
	what_next 2
  )
 )
      )
     )
     ((= what_next 5)
      (if (and	(setq ent (car (entsel)))
	(= "INSERT" (cdr (assoc 0 (entget ent))))
   )
 (setq nom	 (cdr (assoc 2 (entget ent)))
       what_next 1
 )
 (setq what_next 2)
      )
     )
     ((= what_next 0)
      (setq nom nil)
     )
   )
 )
 (unload_dialog dcl_id)
 (vl-file-delete tmp)
 nom
) 

 

[Edité le 5/3/2008 par (gile)]

[mimine]

Merci Gile pour ton aide,j'ai un message d'erreur quand je lance le lisp

erreur dans le fichier de boite de dialogue

"c:\docum........\tmp001.dcl",ligne5:attribut incorrect.

symbole: "dth"

 

Merci beaucoup

[bonuscad]

Pour le

{:button{label=\"Parcourir...\"

, un espace a dut s'insérer lors du copier -coller

 

fixed_wi dth=true;

 

devrait être:

 

fixed_width=true;

 

Tu peux faire la correction en éditant le code et recharger le lisp.

[mimine]

Merci beaucoup Gile pour ton aide très efficace.

 

Bonne journée