AutoCAD Tips

This is a re-post of an earlier post that had an error in it. So here it goes again…

This routine will let you easily find blocks in your drawing. It does this by drawing lines from the insertion point of the blocks to a user specified point.

Here’s how:

• OU <enter> to start
• Notice the options in the command line:

1. select a Block – (default) Select a block from the drawing area
2. Choose from list – select a  block by its name from a list
3. Origin – Specify a point on screen that all of the lines will point to

• After choosing one of these options, you should see lines from all of the instances of the specified block (from their insertion points) to the “origin”

This routine requires that you save 2 files: 1) the .lsp file (LISP) and 2) the .dcl file which is the dialog box for the routine.

Save the below code as OU.dcl

// =================================================================
//
//  OU.DCL V2.12
//
//  Copyright (C) Patrick_35
//
// =================================================================

ou : dialog {
  key = "titre";
  fixed_width = true;
  alignment = centered;
  is_cancel = true;
  width = 40;
  : list_box {label= "Bloc(s)"; key="bl"; height = 15; multiple_select = false;}
  spacer;
  ok_cancel;
}

Save the below code as OU.lsp

;;;=================================================================
;;;
;;; OU.LSP V2.12
;;;
;;; Localiser des blocs
;;;
;;; Copyright (C) Patrick_35
;;;
;;;=================================================================

(defun c:ou(/ bas cle doc ent fic lst nbl pos pt s sel tbl tot totg xd xt
	      *errjou* dessine_ligne msgbox recherche_nom)

  ;;;---------------------------------------------------------------
  ;;;
  ;;; Gestion des erreurs
  ;;;
  ;;;---------------------------------------------------------------

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

  ;;;---------------------------------------------------------------
  ;;;
  ;;; Message
  ;;;
  ;;;---------------------------------------------------------------

  (defun MsgBox (Titre Bouttons Message / Reponse WshShell)
    (vl-load-com)  
    (setq WshShell (vlax-create-object "WScript.Shell"))
    (setq Reponse  (vlax-invoke WshShell 'Popup Message 0 Titre (itoa Bouttons)))
    (vlax-release-object WshShell)
    Reponse
  )

  ;;;---------------------------------------------------------------
  ;;;
  ;;; Filtre les blocs anonymes et ceux associés aux xrefs
  ;;;
  ;;;---------------------------------------------------------------

  (defun recherche_nom(ent)
    (or (wcmatch (vla-get-name ent) "`**,*|*")
	(eq (vla-get-isxref ent) :vlax-true)
      (setq tbl (cons (vla-get-name ent) tbl))
    )
  )

  ;;;---------------------------------------------------------------
  ;;;
  ;;; Dessine une ligne de 0,0 au point d'insertion du bloc
  ;;;
  ;;;---------------------------------------------------------------

  (defun dessine_ligne(ent / bl lay)
    (setq lay (vla-item (vla-get-layers doc) (vla-get-layer ent)))
    (if (vlax-property-available-p ent 'EffectiveName)
      (setq bl (vla-get-effectivename ent))
      (setq bl (vla-get-name ent))
    )
    (if (eq nbl bl)
      (setq totg (1+ totg))
    )
    (and (eq (vla-get-freeze lay) :vlax-false)
	 (eq (vla-get-layeron lay) :vlax-true)
	 (eq (vla-get-lock lay) :vlax-false)
	 (eq nbl bl)
	 (not (member (vlax-make-variant (vla-get-name lay)) lst))
	 (entmake (list (cons 0   "LINE")
			(cons 8   (vla-get-name lay))
			(cons 10  (trans pt 1 0))
			(cons 11  (vlax-get ent 'insertionpoint))
			(cons 410 (vla-get-name (vla-get-layout (vla-objectidtoobject (vla-get-database ent)(vla-get-ownerid ent)))))
		  )
	 )
      (setq tot (1+ tot))
    )
    (princ)
  )

  ;;;---------------------------------------------------------------
  ;;;
  ;;; Routine principale
  ;;;
  ;;;---------------------------------------------------------------

  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object))
	cle "HKEY_CURRENT_USER\\Software\\Autodesk\\Autocad\\Patrick_35"
	s *error*
	*error* *errou*
  )
  (if (vl-registry-read cle "Base_Ou_X")
    (setq pt (list (atof (vl-registry-read cle "Base_Ou_X"))
		   (atof (vl-registry-read cle "Base_Ou_Y"))
		   (atof (vl-registry-read cle "Base_Ou_Z"))
	     )
    )
    (setq pt '(0.0 0.0 0.0))
  )
  (vla-startundomark doc)
  (while (not bas)
    (initget "Choix Origine")
    (setq sel (entsel "\nSelect a Block / Choose from list / Origin : "))
    (if (eq sel "Origine")
      (progn
	(if (setq bas (getpoint (strcat "\nSpecify origin (" (rtos (car pt) (getvar "lunits") 2) "," (rtos (cadr pt) (getvar "lunits") 2) "," (rtos (caddr pt) (getvar "lunits") 2) ") : ")))
	  (progn
	    (setq pt bas)
	    (vl-registry-write cle "Base_Ou_X" (rtos (car pt)))
	    (vl-registry-write cle "Base_Ou_Y" (rtos (cadr pt)))
	    (vl-registry-write cle "Base_Ou_Z" (rtos (caddr pt)))
	  )
	)
	(setq bas nil)
      )
      (setq bas T)
    )
  )
  (if (eq sel "Choix")
    (if (setq fic (findfile "ou.dcl"))
      (progn
	(setq fic (load_dialog fic) pos "0")
	(vlax-map-collection (vla-get-blocks doc) 'recherche_nom)
	(new_dialog "ou" fic "")
	(start_list "bl")
	(mapcar 'add_list (setq tbl (acad_strlsort tbl)))
	(end_list)
	(set_tile "titre" "OU V2.12")
	(set_tile "bl" pos)
	(mode_tile "cancel" 2)
	(action_tile "bl"     "(setq pos $value)")
	(action_tile "accept" "(done_dialog 1)")
	(action_tile "cancel" "(done_dialog 0)")
	(if (eq (start_dialog) 1)
	  (setq nbl (nth (atoi pos) tbl))
	)
	(unload_dialog fic)
      )
      (msgbox "OU" 16 "Le fichier OU.DCL est introuvable.")
    )
    (if sel
      (if (eq (cdr (assoc 0 (entget (car sel)))) "INSERT")
	(progn
	  (setq ent (vlax-ename->vla-object (car sel)))
	  (if (not (vlax-property-available-p ent 'Path))
	    (if (vlax-property-available-p ent 'EffectiveName)
	      (setq nbl (vla-get-effectivename ent))
	      (setq nbl (vla-get-name ent))
	    )
	  )
	)
	(princ "\nThis is not a block.")
      )
    )
  )
  (if nbl
    (if (ssget "x" (list (cons 0 "INSERT") (cons 2 (strcat nbl ",`**"))))
      (progn
	(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-activepviewport (list doc))))
	  (progn
	    (vla-getxdata (vla-get-activepviewport doc) "" 'xt 'xd)
	    (setq lst (vlax-safearray->list xd))
	  )
	)
	(setq totg 0 tot 0)
	(vlax-map-collection (setq sel (vla-get-activeselectionset doc)) 'dessine_ligne)
	(vla-delete sel)
	(princ (strcat "\n" (itoa totg) " " nbl " and found " (itoa tot) " line(s) drawn."))
      )
    )
  )
  (vla-endundomark doc)
  (setq *error* s)
  (princ)
)

(setq nom_lisp "OU")
(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é.....enter " nom_lisp " to start.")))
  (princ (strcat "\n" nom_lisp ".LSP Chargé......enter " nom_lisp " to start.")))
(setq nom_lisp nil)
(princ)