Look for Block in multiple files until found ? Alert if nothing.

[merCADer]

Hello CAD Community,

 

I created a lisp that calls for a block from an external .dwg, but then I realized that what if I end up with hundreds of blocks - then I would need to have hundreds of lisp for each of them and edit the lisp every time a new block gets added into the pool.

 

Fortunately, there are people better at this than me.

 

With the help from great people in the Autodesk forums we have managed to turn this lisp from - every block has its own lisp to a lisp that ask's for what block you want (via getstring) then inserts it in your active drawing.

 

Now, I want to explore options so here I am.

 

What I want to change here is instead of the lisp looking into a single .dwg it looks into multiple .dwg files until it finds the block with that name. I know the lisp would need to have multiple paths to look in to then have "if else" statements, I just dont know how to do it.

 

Here is the lisp:

 

(defun c:TST (/ tst1 s_path blk_b pt)
  (setq tst1 (getstring "enter test string:")
        s_path "../path/path1.dwg"
		blk_b T
  );end_setq
  (cond ((not (tblsearch "block" tst1))
          (steal s_path (list (list "Blocks" (list tst1))))
          (cond ( (not (tblsearch "block" tst1))
                  (alert (strcat "Error! Could not find block  \""  (strcase tst1) "\" in the libraries. please enter an existing block."))
                  (setq blk_b nil)
                )
          );end_cond
        )
  );end_cond
  (cond (blk_b
          (setq pt (getpoint "\nSpecify insertion point: "));
          (command "-insert" tst1 pt);
          (while (= (logand (getvar 'cmdactive) 1) 1)(command ""))
        )
  );end_cond
);end_defun

Thanks!

 

[merCADer]

I think I have figured it out, but please do suggest if this is an effecient way of doing it as I am a novice with Lisps.

 

(defun c:TST2 (/ tst1 s_path blk_b pt)
  (setq tst1 (getstring "enter test string:")
        s_path1 "../path/path1.dwg"
		s_path2 "../path/path2.dwg"
		s_path3 "../path/path3.dwg"
		blk_b T
  );end_setq
  
  (cond ((not (tblsearch "block" tst1))
          (steal s_path1 (list (list "Blocks" (list tst1))))
          (cond ((not (tblsearch "block" tst1))
                  (steal s_path2 (list (list "Blocks" (list tst1))))
                  (setq blk_b nil)
                )
          );end_cond
        )
  );end_cond
  
    (cond ((not (tblsearch "block" tst1))
          (steal s_path2 (list (list "Blocks" (list tst1))))
          (cond ((not (tblsearch "block" tst1))
                  (steal s_path3 (list (list "Blocks" (list tst1))))
                  (setq blk_b nil)
                )
          );end_cond
        )
  );end_cond
  
      (cond ((not (tblsearch "block" tst1))
          (steal s_path3 (list (list "Blocks" (list tst1))))
          (cond ( (not (tblsearch "block" tst1))
                  (alert (strcat "Error! Could not find block  \""  (strcase tst1) "\" in the libraries. please enter an existing block."))
                  (setq blk_b nil)
                )
          );end_cond
        )
  );end_cond
 
  
  (cond (blk_b
          (setq pt (getpoint "\nSpecify insertion point: "));
          (command "-insert" tst1 pt);
          (while (= (logand (getvar 'cmdactive) 1) 1)(command ""))
        )
  );end_cond
);end_defun

 

[merCADer]

Ok. It works but it doesnt.

Anything beyond s_path1 gets a "nil" the first time you run it, but if you run it again, it does insert the block. 

Im not sure how to fix this - but I will try.

[rlx]

couple of weeks ago I was desperately searching the network for a missing block and modified a routine I used to search for a string by means of a quick / dirty fix. It uses odbx and searches all drawings in a folder / subfolders and crashes out as soon as a drawing is found containing the block with a hard exit (very dirty) but hey , it was all I needed at the time. I believe I did change the routine a little bit to show a better progress indicator but I don't have that version here at home. So its only search , no insert...

 

; find block name - written by rlx 12 sep 2019
; uses odbx to process entire folder , type 'fbn' on commandline to start program
; some timings :
; Processed 1012 drawings in 151.234 secs.  - 6.69 dps
; Processed 11355 drawings in 5124.609 secs - 2.21 dps
(defun c:fbn (/ err acapp actdoc actspace acdocs all-open objdbx sf dwg-list start ssl Express ProgBar
                prog-base blk-name)
  (_init) (_exit) (terpri) (princ))

 
(defun find_block_name  ( $dwg / odbxdoc layout obj )
  (if (setq odbxdoc (odbx_open $dwg))
    (progn
      (vlax-for b (vla-get-blocks odbxdoc)
        (if (and (eq "AcDbBlockTableRecord" (vla-get-Objectname b))
                 (equal (strcase (vla-get-name b)) blk-name))
          (progn (alert (strcat "Found it in dwg " $dwg)) (princ $dwg) (exit)) ; not pretty but hey...i was in a hurry
        )
      )
    )
  )
)

 

 
;--- Init ----------------------------------------------- Begin of Init section -------------------------------------------------- Init ---

(defun _init  () (vl-load-com)
   ; initialize ini engine
  (if (not (vl-file-directory-p (setq prog-base (strcat (getvar 'MYDOCUMENTSPREFIX) "\\lisp\\"))))
    (vl-mkdir prog-base))
  (setq err *error*)  (defun *error* (s) (princ s)(_exit))
  (defun _exit () (odbx_releaseall)(and Express ProgBar (acet-ui-progress))(setq *error* err)) (odbx_init)
  (if (and
        (setq blk-name (getstring "Blockname to find : " T)) (not (equal (setq blk-name (strcase blk-name)) ""))
        (setq sf (getfolder "Select source folder for drawings")) (vl-consp (setq dwg-list (fido sf)))
      )
    (progn (setq start (car (_vl-times)))
       (princ (strcat "\nProcessing " (setq l (itoa (length dwg-list))) " drawings..."))
           (progress)(if Express (setq ProgBar (acet-ui-progress "Scanning..." (length dwg-list))))
       (foreach dwg dwg-list
         (if Express (acet-ui-progress -1))
         (find_block_name dwg)
         (if Express (setq ProgBar (acet-ui-progress)))
             (setq blk-name-list nil)
       )
       (princ (strcat "\n\nProcessed " l " drawings in " (rtos (/ (- (car (_vl-times)) start) 1000.) 2 4) " secs.")))
    (princ "\nNo files to process...")
  )
)

(defun progress ()
  (setq Express (and (vl-position "acetutil.arx" (arx))
             (not (vl-catch-all-error-p (vl-catch-all-apply (function (lambda nil (acet-sys-shift-down)))))))))


;--- Init ------------------------------------------------ End of Init section --------------------------------------------------- Init ---


;--- Scripting Object --------------------------------- Begin of Scripting Object ------------------------------------ Scripting Object ---

; Thanks to TonyT - just compressed and tweaked it a little bit
(defun load_fso_scripting  (/ server fso:progid fso:prefix)
  (setq    fso:progid "Scripting.FileSystemObject"    fso:prefix "wsh-")
  (if (not wsh-get-drives)
    (if    (not (setq server (cogetclassserver fso:progid))) (alert "Error: Windows Scripting Host is not installed")
      (vlax-import-type-library    :tlb-filename server :methods-prefix fso:prefix    :properties-prefix fso:prefix :constants-prefix
    (strcat ":" fso:prefix)))))

(defun progid->clsid (progid) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\" progid "\\CLSID")))
(defun cogetclassserver (progid) (cogetclassproperty progid "InprocServer32"))
(defun cogetclassproperty  (progid property / clsid)
  (if (setq clsid (progid->clsid progid)) (vl-registry-read (strcat "HKEY_CLASSES_ROOT\\CLSID\\" clsid "\\" property))))

; Find Drawing Objects - test : (setq lst (fido (dos_path "c:/temp/lisp"))) works also with networkpaths
(defun fido  ($f / fso fld rslt)
  (load_fso_scripting) (setq fso (vla-getinterfaceobject (vlax-get-acad-object) "Scripting.FileSystemObject"))
  (setq    fld  (wsh-getfolder fso $f) rslt (fifo fld "*.dwg"))(vlax-release-object fld)(vlax-release-object fso)  rslt)

; find in folders fl=file ,fls=files, sf=subfolder, sfl=subfolderlist, res=result
(defun fifo  (%dir %ext / fl fls sf sfl res)
  (vlax-for fl    (setq fls (wsh-get-files %dir))
    (if    (wcmatch (strcase (wsh-get-name fl) t) %ext) (setq res (cons (wsh-get-path fl) res)))(vlax-release-object fl))
  (vlax-release-object fls)
  (vlax-for sf (setq sfl (wsh-get-subfolders %dir)) (setq res (append res (fifo sf %ext)))(vlax-release-object sf))
  (release_me (list sfl)) res)

;--- Scripting Object ---------------------------------- End of Scripting Object ------------------------------------- Scripting Object ---

 

;--- Odbx ------------------------------------------------- Begin Odbx Section --------------------------------------------------- Odbx ---

(defun odbx_init  (/ acver)
  (setq    acapp (vlax-get-acad-object) actdoc (vla-get-activedocument acapp) actspace (vla-get-modelspace actdoc)
    acdocs (vla-get-documents acapp) acver (atoi (getvar "ACADVER"))
    all-open (vlax-for dwg acdocs (setq all-open (cons (strcase (vla-get-fullname dwg)) all-open)))
    objdbx (vl-catch-all-apply 'vla-getinterfaceobject
         (list acapp (if (< acver 16) "objectdbx.axdbdocument" (strcat "objectdbx.axdbdocument." (itoa acver))))))
  (if (or (void objdbx) (vl-catch-all-error-p objdbx)) (setq objdbx nil)))

(defun odbx_releaseall    ()
  (mapcar '(lambda (x) (if (and (= 'vla-object (type x)) (not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil))
       (list odbxdoc acdocs objdbx actspace actdoc acapp)) (gc))

(defun odbx_open  (dwg)
  (if objdbx (if (member (strcase dwg) all-open)
           (odbx_open_copy (findfile dwg))(vl-catch-all-apply 'vla-open (list objdbx (findfile dwg))))) objdbx)

(defun odbx_open_copy  (dwg / copy)
  (vl-file-copy (findfile dwg) (setq copy (vl-filename-mktemp nil nil ".dwg")))(vla-open objdbx (findfile copy))  objdbx)

;--- Odbx -------------------------------------------------- End Odbx Section ---------------------------------------------------- Odbx ---


;--- + + + --------------------------------------------- Begin of tiny lisp section --------------------------------------------- + + + ---

(defun wait  (sec / stop) (setq stop (+ (getvar "DATE") (/ sec 86400.0))) (while (> stop (getvar "DATE"))))
;(defun void  (x) (if (member x (list "" " " "  " "   " "       " nil '())) t nil))
(defun void (x) (or (null x) (and (= (type x) 'STR) (= "" (vl-string-trim " \t\r\n" x)))))

(defun e2v (e)(vlax-ename->vla-object e)) ;||; (defun v2e (o)(vlax-vla-object->ename o)) ;||; (defun _type (e)(cdr (assoc 0 (entget e))))

(defun release_me  (lst)
  (mapcar '(lambda (x)(if (and (= 'vla-object (type x))(not (vlax-object-released-p x)))(vlax-release-object x))(set (quote x) nil)) lst))

(defun getfolder  (msg / fl sh)
  (if (and (setq sh (vlax-create-object "Shell.Application"))(setq fl (vlax-invoke sh 'browseforfolder 0 msg 0 "")))
    (setq fl (vlax-get-property (vlax-get-property fl 'self) 'path))(setq fl nil))(release_me (list sh)) fl)

(defun get_block_name (b)
  (cond ((vlax-property-available-p b 'effectivename) (vla-get-effectivename b)) ((vlax-property-available-p b 'name) (vla-get-name b))))

; make sure path is corect for scripting object (dos_path (strcat (getvar "dwgprefix") (getvar "dwgname")))
(defun dos_path     ($p) (if (= (type $p) 'str) (strcase (vl-string-translate "/" "\\" $p)) ""))

;--- + + + ---------------------------------------------- End of tiny lisp section ---------------------------------------------- + + + ---

(princ "\nFind Block Name - RLX 12 sep 2019 : Type 'FBN' on commandline to start program\n")
(princ)

; (c:fbn)

Edited October 3, 2019 by rlx

[BIGAL]

Something similar its a DOS command findstr, I am forever trying to find a vl syntax so you can do findstr closest *.lsp and it will display all the lisps that have that word in it. I have it as a bat so looks in lisp files area.

 

Back to the post have you looked at palettes or a block library of dwg's it sounds to me like your reproducing the same thing multiple times if you forget the block name.