Quick String Search

[rlx]

;;; QSS - Quick String Search Rlx 5/'26
;;; Just a basic string search engine, primarily meant for text based files like lsp + txt files & dwg files (dbx)
;;; Some files are read as stream so maybe it also works for other file types ... bucketlist material.
;;; On my home computer text search in total commander stopt working so decided to do it myself.
;;; Also Total commander was removed from my work computer. I allready lispify some other
;;; Total Commander functions like copy, move & rename but those live in my batch program.
;;; Main use for me is sometimes I remember making a lisp but not remembering how I named it or where I saved it.
;;; At moment of writing this app is still in beta.

(defun C:QSS
       ( /
        ;;; globals
        OldErr regkey regvar sysvar-names sysvar-old-values total-file-list hit-list
        qss-open-dwg-on-your-way-out fn
        ;;; object dbx / RegExp
        actApp actDoc actDocs actLay actDbx AllOpen RegExp
        ;;; registry
        QSS-Search-Folder					;;; String - Folder where lisp files are placed
        QSS-Include-Subfolders					;;; Toggle - "0" scan only search folder, "1" also scan subfolders
        QSS-Filename-Extension-Filter				;;; String - delimited by , like "lsp,txt"
        QSS-Search-String-Filter				;;; String - delimited by | like "Rlx|Dragon"
        QSS-Case-Sensitive					;;; Toggle - "0" don't care, "1" case sensitive search
        QSS-Whole-Words-Only					;;; Toggle - "0" find every part, "1" only find whole words

        ;;; dialog
        QSS-Main-Dialog-fn QSS-Main-Dialog-fp QSS-Main-Dialog-id
	MainDialog-tl MainDialog-rd
	
       )
  (QSS_init)
  (QSS_exit)
  (if (and qss-open-dwg-on-your-way-out (setq fn (findfile qss-open-dwg-on-your-way-out)))(_ShellOpen fn))
)

;--- Init ------------------------------------------------- Begin Init Section --------------------------------------------------- Init ---

(defun QSS_Init ()
  ; initialize error handling
  (setq OldErr *error* *error* QSS_Err)
  ; backup & set system variables (not realy used here, just added for template purposes)
  (setq sysvar-names (list (cons 'cmdecho 0))
        sysvar-old-values (mapcar '(lambda (x)(getvar (car x))) sysvar-names))
  (mapcar '(lambda (x)(setvar (car x) (cdr x))) sysvar-names)
  ;;; init registry variables
  (InitDefaultRegistrySettings)(ReadSettingsFromRegistry)
  ;;; lets go girls
  (QSS_Main_Dialog_Start)
)

(defun QSS_Err ($s) (princ $s)(QSS_Exit)(setq *error* OldErr)(princ))

(defun QSS_Exit ()
  ; cleanup dialog(s) (I use list for future use in case of more dialogs)
  (mapcar '(lambda (x) (if (not (null x)) (unload_dialog x)))
	   (list QSS-Main-Dialog-fn))
  (mapcar '(lambda (x) (if (not (null x)) (close x)))
	   (list QSS-Main-Dialog-fp))
  (mapcar '(lambda (x) (if (and (not (null x)) (findfile x)) (vl-file-delete x)))
	   (list QSS-Main-Dialog-fn))
                 
  ; reset system variables (not realy used here just for future / template purposes)
  (mapcar '(lambda (x y)(setvar (car x) y)) sysvar-names sysvar-old-values)
  (term_dialog) (gc) (princ "\nDone") (terpri) (princ)
  ; release actDbx & RegExp
  (foreach obj (list actDbx RegExp) (vl-catch-all-apply 'vlax-release-object (list obj)))
)


;;; ------------------------------------------------------ End of Init Section ------------------------------------------------------------



;;; --- Registry Settings ------------------------------- Begin Registry Settings ------------------------------- Registry Settings --- ;;;

(defun InitDefaultRegistrySettings ()
  (setq regkey "HKEY_CURRENT_USER\\SOFTWARE\\QSS\\")
  ;;; regkeys must be strings ("variable name" "default value")
  (setq regvar
     (list
       '("QSS-Search-Folder" "")				;;; String - Folder where lisp files are placed
       '("QSS-Include-Subfolders" "0")				;;; Toggle - "0" scan only search folder, "1" also scan subfolders
       '("QSS-Filename-Extension-Filter" "lsp,txt,dwg")		;;; String - delimited by , (comma) like "lsp,dwg"
       '("QSS-Search-String-Filter" "")				;;; String - delimited by | (Pipe) like "Rlx|Dragon"
       '("QSS-Case-Sensitive" "0")				;;; Toggle - "0" don't care, "1" case sensitive search
       '("QSS-Whole-Words-Only" "0")				;;; Toggle - "0" nope , "1" jip
    )
  )
  (mapcar '(lambda (x)(set (read (car x)) (cadr x))) regVar)
)

(defun ReadSettingsFromRegistry ()
  (mapcar '(lambda (x / n v)
    (if (setq v (vl-registry-read regkey (setq n (car x)))) (set (read n) v) (vl-registry-write regkey n (cadr x)))) regvar))

(defun WriteSettingsToRegistry ()
  (mapcar '(lambda (x) (vl-registry-write regkey (car x) (eval (read (car x))))) regvar))

;;; --- Registry Settings -------------------------------- End Registry Settings -------------------------------- Registry Settings --- ;;;



;;; --- dialog section ----------------------------------- begin dialog section ------------------------------------ dialog section --- ;;;

; SaveDialogData evaluates all vars from %tl and returns them as a list, reset does the opposite
(defun Save_Dialog_Data      (%tl) (mapcar '(lambda (x) (eval (car x))) %tl))
(defun Reset_Dialog_Data (%tl %rd) (mapcar '(lambda (x y) (set (car x) y)) %tl %rd))
(defun Set_Dialog_Tiles      (%tl) (mapcar '(lambda (x / v) (if (eq 'str (type (setq v (eval (car x))))) (set_tile (cadr x) v))) %tl))
(defun Main_Dialog_Cancel       () (Reset_Dialog_Data MainDialog-tl MainDialog-rd) (WriteSettingsToRegistry))

(defun QSS_Main_Dialog_Create ()
  (if (and (setq main-dialog-fn (vl-filename-mktemp "Main.dcl")) (setq main-dialog-fp (open main-dialog-fn "w")))
    (mapcar
      '(lambda (x)(write-line x main-dialog-fp))
       (list "QSS : dialog {label=\"QSS - Quick String Search (RLX May 2026)\";"
             ":boxed_column {label=\"Search folder :\";"
               ":row {:edit_box {key=\"eb_search_folder\";}"
                     ":button {fixed_width=true;width=12;key=\"bt_select_search_folder\";label=\"Select\";}}"
               ":toggle {label=\"Include subfolders\";key=\"tg_include_subfolders\";}}"

             ":boxed_row {label=\"Filename Extension Filter [ , ]\"; :edit_box {key=\"eb_filename_extension_filter\";}}"
	     
	     ":boxed_column {label=\"Search string filter [ | ]\";"
               ":edit_box {key=\"eb_search_string_filter\";}"
               ":row {:toggle {label=\"Case sensitive\";key=\"tg_case_sensitive\";}"
               "      :toggle {label=\"Whole words only\";key=\"tg_whole_words_only\";}}}"
             
             "spacer;"
             ":concatenation {gap; :image {height=1.5;width=91;key=\"the_bar\";color=dialog_background;}gap;}"
             "spacer;ok_cancel;spacer;"
             "}"
             "gap:image {fixed_width=true;width=0.001;color=dialog_background;}"
       )
    )
  )
  (if main-dialog-fp (close main-dialog-fp))(gc)
)

(defun QSS_Main_Dialog_Start ( / drv )
  (if (null main-dialog-fn)(QSS_Main_Dialog_Create))
  (if (and (setq main-dialog-dcl (load_dialog main-dialog-fn)) (new_dialog "QSS" main-dialog-dcl))
    (progn
      (QSS_Main_Dialog_Update)
      (QSS_Main_Dialog_Action)
      (setq drv (start_dialog))
      
      (cond
	((= drv  0)(Main_Dialog_Cancel))
	((= drv  1)(WriteSettingsToRegistry)(QSS_DoIt))
        ((= drv  2)(WriteSettingsToRegistry)(Show_Hit_List))
      )
    )
  )
  (if main-dialog-fn (vl-file-delete main-dialog-fn))
  (setq main-dialog-fn nil)
)

(defun QSS_Main_Dialog_Update ()
  (setq MainDialog-tl
	 '((QSS-Search-Folder "eb_search_folder")
           (QSS-Include-Subfolders "tg_include_subfolders")
           (QSS-Filename-Extension-Filter "eb_filename_extension_filter")
           (QSS-Search-String-Filter "eb_search_string_filter")
           (QSS-Case-Sensitive "tg_case_sensitive")
           (QSS-Whole-Words-Only "tg_whole_words_only")
          )
  )
  ;;; rd = reset data (val1 val2 ...) , in case of a cancel store original values before start of dialog
  (if (null MainDialog-rd) (setq MainDialog-rd (Save_Dialog_Data MainDialog-tl)))
  ;;; set edit boxes and toggle values
  (Set_Dialog_Tiles MainDialog-tl)
)

(defun QSS_Main_Dialog_Action ()
  (mapcar '(lambda (x)(action_tile (car x) (cadr x)))
    '(("cancel" "(done_dialog 0)") ;("accept" "(done_dialog 1)")
      ("accept" "(QSS_Pre_Scan)")
      ("eb_search_folder" "(setq QSS-Search-Folder $value)")
      ("bt_select_search_folder" "(QSS_select_search_folder)")
      ("tg_include_subfolders" "(setq QSS-Include-Subfolders $value)")
      ("eb_filename_extension_filter" "(setq QSS-Filename-Extension-Filter $value)")
      ("eb_search_string_filter" "(setq QSS-Search-String-Filter $value)")
      ("tg_case_sensitive" "(setq QSS-Case-Sensitive $value)")
      ("tg_whole_words_only" "(setq QSS-Whole-Words-Only $value)")
    )
  )
)

(defun QSS_select_search_folder ( / f)
  (if (setq f (GetShellFolder "Select search folder"))(set_tile "eb_search_folder" (setq QSS-Search-Folder f))))

;;; first handle the file & folder stuf side of things
(defun QSS_Pre_Scan ( / subfolder-flag case-flag filename-extension-filter-list search-string-filter-list folder-list tmp-l)
  ;;; make sure include subfolders and case-sensitive flags are either T or nil
  (if (not (eq QSS-Include-Subfolders "1")) (setq subfolder-flag nil) (setq subfolder-flag T))
  (if (not (eq QSS-Case-Sensitive "1")) (setq case-flag nil) (setq case-flag T))
  ;;; check all parameters
  (cond
    ;;; verify search folder
    ((not (folder-p QSS-Search-Folder))
     (alert (strcat "Invalid search folder : " (vl-princ-to-string QSS-Search-Folder))))
    ;;; verify filename filter (like "lsp,dwg") -> pimpext -> ("*.lsp" "*.dwg")
    ((or (void QSS-Filename-Extension-Filter)
         (not (vl-consp (setq tmp-l (SplitStr QSS-Filename-Extension-Filter ","))))
         (not (vl-every '(lambda (s) (wcmatch s "*`.*")) (setq filename-extension-filter-list (pimpex tmp-l)))))
     (alert (strcat "Bad filename filter : " (vl-princ-to-string QSS-Filename-Extension-Filter))))
    ;;; verify search string filter
    ((or (void QSS-Search-String-Filter)
         (not (vl-consp (setq search-string-filter-list (SplitStr QSS-Search-String-Filter "|")))))
     (alert (strcat "Invalid search string : " (vl-princ-to-string QSS-Search-String-Filter))))
    ;;; maybe do file list check here
    (t
     ;;; show something wonderfull is about to happen
     (clear_bar)(set_tile "the_bar" " working...")
     (if (eq QSS-Include-Subfolders "1")
       (setq folder-list (QSS_FindSubfolders QSS-Search-Folder)) (setq folder-list (list QSS-Search-Folder)))
     ;;; just a little delay to enjoy the view, exterminate when it gets anoying
     (wait 1.5)
     (setq total-file-list (QSS_FindFiles folder-list filename-extension-filter-list))
     (wait 1.5)
     (if (not (vl-consp total-file-list))
       (alert (strcat "no files found :\nFolder : " (vl-princ-to-string QSS-Search-Folder)
                      "\nFilter : " (vl-princ-to-string filename-extension-filter-list)))
       (QSS_Process_Total_File_List)
     )
    );;; end t
  );;; end cond
);;; end defun

;;; clear previous status
(defun clear_bar () (start_image "the_bar")(fill_image 0 0 (dimx_tile "the_bar") (dimy_tile "the_bar") 141)(end_image))

(defun Show_Hit_List () (if (vl-consp hit-list)
  (dplm+ hit-list (strcat "Number of files found : " (itoa (length hit-list)))) (alert "Sorry search returned no results")))

(defun QSS_Process_Total_File_List ( / stream pattern file-count n l hit)
  (set_tile "the_bar" (strcat "Number of files to search : " (setq n (itoa (length total-file-list)))))
  (setq file-count 0 pattern QSS-Search-String-Filter)
  (if (eq QSS-Case-Sensitive "1")(setq ignoreCase nil)(setq ignoreCase T))
  (foreach fn total-file-list
    ;;; split here for different types of extensions
    ;;; lisp & text files can be read by stream , dwg by odbx
    ;;; (strcase (last (fnsplitl "c:\\temp\lisp\acad.dwg")) t) -> ".dwg"
    (setq ext (strcase (last (fnsplitl fn)) t))

    ;;; for now only *.lsp, *.txt & *.dwg,
    ;;; bucketlist xls/xlsx & pdf but they may need different approach or 3rd party software, so low priority
    (cond
      ((wcmatch ext "*`.lsp,*`.txt")
       (if (and (setq stream (_ReadStream fn 0))
                (setq rtn (= (vlax-invoke (InitRegExp pattern ignoreCase nil) 'Test stream) -1))
                (not (member fn hit-list))) (setq hit-list (cons fn hit-list))))
      ;;; regex_string_search last parameter is for return as list
      ;;; if T -> return all strings in doc as list, if nil -> return nil or filename if pattern is found
      ((wcmatch ext "*`.dwg")
       (if (and (setq dbx-doc (odbx_open fn)) (setq hit (regex_string_search dbx-doc pattern nil)))
         (setq hit-list (cons fn hit-list))))
    )
    ;;; length of hit-list
    (setq l (itoa (length hit-list)))
    ;;; clear previous status
    (clear_bar)
    ;;; update status message
    (set_tile "the_bar" (strcat "   ( " (setq *spin* (Spinbar *spin*)) " ) Scanning files [" (itoa file-count) " of " n "] - found " l))
    ;;; increase file counter
    (setq file-count (1+ file-count))
  )
  (done_dialog 2)
)


;;; --- dialog section ------------------------------------ end dialog section ------------------------------------- dialog section --- ;;;



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

(defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))

(defun wait (sec / stop)(setq stop (+ (getvar "DATE") (/ sec 86400.0)))(while (> stop (getvar "DATE"))))

(defun string-p (s) (if (= (type s) 'str) t nil))

(defun folder-p (f) (if (and (= (type f) 'str) (vl-file-directory-p f)) t nil))

;;; (Dos_Path (strcat (getvar "dwgprefix") (getvar "dwgname"))) -> "C:\\USERS\\ROB\\DOCUMENTS\\ACAD\\QUICKSTRINGSEARCH.DWG\\"
(defun Dos_Path ($p)
  (if (= (type $p) 'STR) (strcase (strcat (vl-string-right-trim "\\" (vl-string-translate "/" "\\" $p)) "\\")) ""))

;;; (vl_path (strcat (getvar "dwgprefix") (getvar "dwgname"))) -> "c:/users/rob/documents/acad/quickstringsearch.dwg/"
(defun vl_path ($p)(if (= (type $p) 'str)
   (strcat (vl-string-right-trim "\\/" (strcase (vl-string-translate "\\" "/" $p) t)) "/") ""))

; generic getfolder routine with possibility to create a new subfolder (GetShellFolder "select path")
(defun GetShellFolder ( m / f s) (if (and (setq s (vlax-create-object "Shell.Application"))
  (setq f (vlax-invoke s 'browseforfolder 0 m 0 "")))(setq f (vlax-get-property (vlax-get-property f 'self) 'path))
     (setq f nil))(vl-catch-all-apply 'vlax-release-object (list s))
  (if f (strcat (vl-string-right-trim "\\" (vl-string-translate "/" "\\" f)) "\\")))

; returns T if no errors occurred during program execution
(defun _ShellOpen ( $f / it sh )
  (if (and (not (void $f)) (setq $f (findfile $f)) (setq sh (vla-getInterfaceObject (vlax-get-acad-object) "Shell.Application")))
    (progn (setq it (vl-catch-all-apply 'vlax-invoke (list sh 'open $f)))(vlax-release-object sh)(not (vl-catch-all-error-p it)))
      (progn (prompt "\nShell application was unable to open file")(setq it nil))))

;;; d = directory , e = extension like "*.dwg" , f = flag include subfolders (any value or nil)
;;; test : (length (alf "d:/temp/lisp" "*.dwg" t))  (length (alf "d:/temp/lisp" "*.dwg" nil))
;;; (setq l (alf "c:/temp/lisp" "*.xlsx" t)) (setq l (alf "c:\\temp\\lisp\\" "*.txt" t))
(defun alf (d e f) (setq d (vl-string-right-trim "/" (vl-string-translate "\\" "/" d)))
  (if f (apply 'append (cons (if (vl-directory-files d e)(mapcar '(lambda (x) (strcat d "/" x)) (vl-directory-files d e)))
    (mapcar '(lambda (x) (alf (strcat d "/" x) e f))(vl-remove ".." (vl-remove "." (vl-directory-files d nil -1))))))
      (mapcar '(lambda (x) (strcat d "/" x))(vl-directory-files d e 1))))

;;; (SplitStr "a,b,c" ",") -> ("a" "b" "c")
(defun SplitStr (s d / p)
  (if (setq p (vl-string-search d s))(cons (substr s 1 p)(SplitStr (substr s (+ p 1 (strlen d))) d))(list s)))

;;; (lst->csv '("a" "b" "c") "|") -> "a|b|c"
(defun lst->csv (%l $s)
  (apply 'strcat (cdr (apply 'append (mapcar (function (lambda (x) (list $s x))) %l)))))

;;; (sandwich '("a" "b" "c") "*") -> '("*a*" "*b*" "*c*")
;;; for whole word search each string in regex string has to begin and end with \\b
(defun sandwich (%l %c) (mapcar '(lambda (s)(strcat %c s %c)) %l))

;;; make sure each extension begin with *. (pimpex (splitstr "lsp,dwg" ",")) -> ("*.lsp" "*.dwg")
(defun pimpex (%l) (mapcar '(lambda (s)(strcat "*." (vl-string-trim "*." s))) %l))

; choose from list (cfl '("1" "2" "3"))
(defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
 (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p)
  (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
   (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
    (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)")
     (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

;;; display list (plus message)
(defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";"
   "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb")
     (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f))))

;;; possibility to load / save the list and ShellOpen selection
(defun dplm+ (l m / load_list save_list open_item f p d w pick)
  (defun load_list ()(alert "Under construction : Load List"))  (defun save_list ()(alert "Under construction : Save List"))
  (defun open_item ( / i f)(if (and (vl-consp l)(not (null pick))(setq i (atoi pick))(setq f (nth i l))(setq f (findfile f)))
    (cond ((wcmatch (strcase (last (fnsplitl f)) t) "*.dwg")(setq qss-open-dwg-on-your-way-out f)(done_dialog))(t (_ShellOpen f)))))

  (if (not (vl-consp l)) (setq l (list "No results")) (setq l (mapcar 'vl-princ-to-string l)))
  ;;; make width dialog based on longest string in list
  (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
  (write-line (strcat "cfl:dialog{label=\"" m "\";") p)
  (write-line (strcat ":list_box {key=\"lb\";width=" (itoa w) ";height=25;}") p)
  (write-line (strcat ":column {:row {fixed_width=true;alignment=centered; :button {key=\"bt_load\";label=\"Load\";}"
                          ":button {key=\"bt_save\";label=\"Save\";} :button {key=\"bt_open\";label=\"Open\";}}}") p)
  (write-line "ok_only;}" p)
  
  (if p (close p))
  (if (and (< 0 (setq d (load_dialog f))) (new_dialog "cfl" d))
    (progn
      (start_list "lb")(mapcar 'add_list l)(end_list)
      (action_tile "accept" "(done_dialog)") (action_tile "lb" "(setq pick $value)") (action_tile "bt_load" "(load_list)")
      (action_tile "bt_save" "(save_list)")  (action_tile "bt_open" "(open_item)") (start_dialog) (unload_dialog d) (vl-file-delete f)
    )
  )
)

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


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

(defun GetAllOpenDocs ()
  (or actApp (setq actApp (vlax-get-acad-object))) (or actDoc (setq actDoc (vla-get-ActiveDocument actApp)))
    (or actDocs (setq actDocs (vla-get-documents actApp)))
  (vlax-for doc actDocs (if (= 1 (vlax-variant-value (vla-getvariable doc "DWGTITLED"))); no nameless drawings
    (setq AllOpen (cons (cons (strcase (vla-get-fullname doc)) doc) AllOpen))))
)
       
(defun _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 actLay actDoc actDocs actApp actDbx))(gc))

(defun _ReleaseAll ()
  (mapcar '(lambda(x) (if (and (= 'vla-object (type x)) (not (vlax-object-released-p x)))
    (vlax-release-object x))(set x nil)) (list 'doc 'actLay 'actDoc 'actDocs 'actApp 'actDbx))(gc))

(defun _InitObjectDBX ()(or actApp (setq actApp (vlax-get-acad-object)))
  (or actDoc (setq actDoc (vla-get-ActiveDocument actApp)))(or AllOpen (setq AllOpen (GetAllOpenDocs)))
  (setq actDbx (vl-catch-all-apply 'vla-getinterfaceobject (list actApp (dbx_ver))))
  (if (or (null actDbx)(vl-catch-all-error-p actDbx))(progn (princ "\nObjectDbx not available")(setq actDbx nil)))
  actDbx
)


(defun odbx_open ( $dwg / _pimp doc) (or AllOpen (GetAllOpenDocs))
  (defun _pimp (s) (strcase (vl-string-trim " ;\\" (vl-string-translate "/" "\\" s))))
  (cond ((or (void $dwg) (not (findfile $dwg)))(princ "\nInvalid drawing")(setq doc nil))
	((not (or actDbx (_InitObjectDBX)))(princ "\nObjectDbx not available")(setq doc nil))
        ((setq doc (cdr (assoc (_pimp $dwg) AllOpen))))
	((vl-catch-all-error-p (vl-catch-all-apply 'vla-Open (list actDbx (findfile $dwg))))
	 (princ "\nUnable to open drawing.")(setq doc nil))
	(t (setq doc actDbx)))
  doc
)

(defun odbx_close ( %doc ) (if (and (= 'vla-object (type %doc))
  (not (vlax-object-released-p %doc)))(progn (vlax-release-object %doc))(setq %doc nil)))

(defun dbx_ver ( / v)
  (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))

;;; little test function to find all strings (txt/att etc) in all drawings in a folder
(defun c:test1 ( / actDoc actDocs actApp actDbx RegExp dbx-doc write_result show_result 
                 search-folder dwg-list rtn result-list search-pattern result-list-fn)
  
  ;;; init vl functions, odbx & regexp
  (vl-load-com) (_InitObjectDBX) (or RegExp (setq RegExp (vlax-create-object "VBScript.RegExp")))
  
  (defun write_result (lst fn / fp)
    (cond
      ((not (vl-consp lst))
       (alert "Computer says no : empty result list, nothing to write"))
      ((or (not (= (type fn) 'STR)) (not (setq fp (open fn "w"))))
       (alert (strcat "unable to write to : " (vl-princ-to-string fn))))
      ;;; format lst : ( ("dwgname1" . ("str1" "str2" ...)) ...)
      (t
       (write-line (strcat "Scanned " (itoa (length lst)) " drawings\n") fp)
       (foreach item lst
         (write-line (car item) fp)
         (foreach str (cdr item) (write-line (vl-princ-to-string str) fp))
         (write-line "\n--\n" fp)
       )
      )
    )
    (if fp (progn (close fp)(gc)(gc))) 
    (princ)
  )
  
  (defun show_result (fn)
    (if (and fn (setq fn (findfile fn)))
      (startapp "notepad" fn)
      (alert (strcat "Computer says no : unable to read from : " (vl-princ-to-string fn)))
    )
    (princ)
  )
  
  (setq search-pattern "*" result-list-fn "C:\\Temp\\QuickStringSearchResult.txt")
  (cond
    ;;; hard coded for test, could be replaced with something like :
    ;;; ((not (or (vl-file-directory-p (setq search-folder "C:\\Temp\\Lisp\\"))
    ;;;           (setq search-folder (getfolder "Folder for string search"))))"
    ;;;  (alert (strcat "computer says no : invalid folder : " search-folder)))
    ((not (vl-file-directory-p (setq search-folder "C:\\Temp\\Lisp\\")))
     (alert (strcat "Folder " search-folder " does not exist - change folder")))
    ((not (vl-consp (setq dwg-list (vl-directory-files search-folder "*.dwg"))))
     (alert (strcat "No dwg files in " search-folder)))
    (t
     ;;; if return-as-list is T regex_string_search returns all strings else T or nil if pattern is found
     (setq return-as-list T)
     (foreach dwg dwg-list
       (if (setq dbx-doc (odbx_open dwg))
         (if (vl-consp (setq rtn (regex_string_search dbx-doc search-pattern return-as-list)))
           (setq result-list (cons (cons dwg rtn) result-list)))
         (princ (strcat "\nUnable to open " dwg))
       )
     )
     (_ReleaseAll)
    )
  )

  ;;; release RegExp
  (if (= 'vla-object (type RegExp))(vlax-release-object RegExp))
  
  (if (vl-consp result-list)
    (progn (write_result result-list result-list-fn) (show_result result-list-fn))
    (princ (strcat "\nNo text was found in dwg files in " (vl-princ-to-string search-folder)))
  )
  (princ)
)

;;; doc = duh , pat = duh , ral = return as list , if T return all strings , if nil test for pattern and return nil or T
(defun regex_string_search (doc pat ral / pat-p blocks objName textStr atts result s tableRow tableCol)
  ;;; not realy needed because als called in test function
  (or RegExp (setq RegExp (vlax-create-object "VBScript.RegExp")))

  ;;; *** still to do create regex version, not sure pat-p is working as intended
  ;;; test if pattern is found in list of strings (RegExp needs to be initialized)
  (defun pat-p (p l) (vl-some (function (lambda (s)(= (vlax-invoke-method RegExp 'Test p) :vlax-true))) l))

  ;;; *** still to do : apply ignore case / whole words only to pattern
  ;;; alternative : (lwcmatch "M-16427" '("As built K-16886.pdf" "As built M-16427.pdf" "As built N-16260.pdf"))
  (defun lwcmatch (p l / r)(foreach x l (if (vl-string-search p x)(setq r (cons x r)))) r)
  
  (setq blocks (vla-get-blocks doc))
  (if (/= pat "")
    (progn
      ;;; mmm, do I realy need RegExp for this?
      (vlax-put-property RegExp 'Pattern pat)
      (vlax-put-property RegExp 'IgnoreCase :vlax-true)
      (vlax-put-property RegExp 'Global :vlax-true)
      (vlax-for block blocks
        (vlax-for obj block
          (setq objName (vlax-get-property obj 'ObjectName))
          (setq textStr nil)
          ;;; Filter objects & get textString
          (cond
            ;; Text en MText
            ((vl-position objName '("AcDbText" "AcDbMText"))
             (setq textStr (vlax-get-property obj 'TextString)))
            ;; Old Leaders & Dimensions
            ((vl-position objName '("AcDbLeader" "AcDbDimension" "AcDbRotatedDimension" "AcDbAlignedDimension"))
             (if (vlax-property-available-p obj 'TextOverride)
               (setq textStr (vlax-get-property obj 'TextOverride))))
            ;; Modern MultiLeaders (MLeader)
            ((= objName "AcDbMLeader")
             (if (= (vlax-get-property obj 'ContentType) 2) ; 2 = acMTextContent
               (setq textStr (vlax-get-property obj 'TextString))))
            ;; Block Reference with Attributes
            ((= objName "AcDbBlockReference")
             (if (= (vlax-get-property obj 'HasAttributes) :vlax-true)
               (progn
                 (setq atts (vlax-invoke obj 'GetAttributes))
                 (foreach attObj atts
                   (setq s (vlax-get-property attObj 'TextString))
                   (if (and s (/= s "")) ;(= (vlax-invoke-method RegExp 'Test pat) :vlax-true))
                     (progn (setq textStr (cons  (strcat "Block " (vlax-get-property obj 'Name)
                         ", Tag : " (vlax-get-property attObj 'TagString) ", Text : " s) textStr))))
                 )
               )
             )
            )
            ;; Tabellen (Scant elke cel afzonderlijk)
            ((= objName "AcDbTable")
             (setq tableRow 0)
             (while (< tableRow (vlax-get-property obj 'Rows))
               (setq tableCol 0)
               (while (< tableCol (vlax-get-property obj 'Columns))
                 (setq s (vlax-invoke obj 'GetText tableRow tableCol))
                 (if (and s (/= s "")); (= (vlax-invoke-method regex 'Test textStr) :vlax-true))
                   (setq textStr (cons  (strcat "Table [Row " (itoa tableRow) ", Col " (itoa tableCol) "]: " s) textStr)))
                 (setq tableCol (1+ tableCol))
               )
               (setq tableRow (1+ tableRow))
             )
            )
          ) ;;; end cond
          
          ;;; put result in list
          (cond
            ((null textStr))
            ((vl-consp textStr) (foreach x textStr (setq result (cons x result))))
            (t (setq result (cons textStr result)))
          )
        ) ;;; vlax-for block
      ) ;;; vlax-for blocks
    ) ;;; end progn
  ) ;;; end if (/= pat "")

  ;;; if ral = T return all strings as list else only return T if pattern is found in result list
  ;;; *** still to do replace lwcmatch with regex version (pat-p)
  (if ral result (lwcmatch pat result))
)


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




;;; --- RegExp -------------------------------------------------- RegExp --------------------------------------------------- RegExp --- ;;;


;;; Separate multiple patterns by pipe-operator |
;;; (vlax-put-property regexp "Pattern" "Rlx|CadTutor|Visual Lisp")
;;; Whole words only (not "Rlxie" when searching for "Rlx"):
;;; (vlax-put-property regexp "Pattern" "\\bRlx\\b|\\bCadTutor\\b|\\bVisual Lisp\\b")

;;; pattern	: Pattern to search.
;;; ignoreCase	: If non nil, the search is done ignoring the case.
;;; global	: If non nil, search all occurences of the pattern, if nil, only searches the first occurence.
(defun InitRegExp (pattern ignoreCase global)
  (or RegExp (setq RegExp (vlax-create-object "VBScript.RegExp")))
  (vlax-put RegExp 'Pattern pattern)
  (if ignoreCase (vlax-put RegExp 'IgnoreCase acTrue)(vlax-put RegExp 'IgnoreCase acFalse))
  (if global (vlax-put RegExp 'Global acTrue)(vlax-put RegExp 'Global acFalse))
  RegExp
)

;;; len :  Number of bytes to read. If non numeric, < 1 or greater than the number of bytes in file everything is returned.
;;; iomode : 1 = read, 2 = write, 8 = append , format : 0 = ascii, -1 = unicode, -2 = system default
(defun _ReadStream ( path len / fso file stream result )
  (vl-catch-all-apply
    '(lambda ( / iomode format size )
       (setq iomode 1 format 0 fso (vlax-create-object "Scripting.FileSystemObject") file (vlax-invoke fso 'GetFile path)
	     stream (vlax-invoke fso 'OpenTextFile path iomode format) size (vlax-get file 'Size)
	     len (if (and (numberp len) (< 0 len size)) (fix len) size) result (vlax-invoke stream 'read len))
       (vlax-invoke stream 'Close)
     )
  )
  (if stream (vlax-release-object stream))(if file (vlax-release-object file))(if fso (vlax-release-object fso))
  result
)


;;; T if pattern is found else nil
(defun c:test2 ( / fn pattern stream ignoreCase rtn)
  (setq fn "C:\\Temp\\Lisp\\RlxBatch.lsp")
  (setq ignoreCase T)
  (setq pattern "-publish")
  ;(setq pattern "dragon")
  (and
    (= (type fn) 'STR)
    (setq fn (findfile fn))
    (setq stream (_ReadStream fn 0))
    (setq rtn (= (vlax-invoke (InitRegExp pattern ignoreCase nil) 'Test stream) -1))
  )
  rtn
)

;;; --- RegExp -------------------------------------------------- RegExp --------------------------------------------------- RegExp --- ;;;

;;; -------------------------------------------------- Begin of Progress Bar Section ------------------------------------------------------

; (setq lst (acad_strlsort (QSS_FindSubfolders "c:/temp/lisp")))
(defun QSS_FindSubfolders ( d / l r s msg ) (setq l (list d))
  (while l (setq s nil)(foreach d l (setq s (append s (mapcar (function (lambda ( x ) (strcat d "/" x)))
    (vl-remove-if (function (lambda (x)(member x '("." ".."))))(vl-directory-files d nil -1))))))(setq r (append s r) l s)
      (start_image "the_bar")(fill_image 0 0 (dimx_tile "the_bar") (dimy_tile "the_bar") 131)(end_image)
      (setq msg (strcat "   ( " (setq *spin* (Spinbar *spin*))" ) Scanning for subfolders : " (itoa (length r))))
      (set_tile "the_bar" msg)
  )
  ;;; make sure sourcefolder is part of result
  (cons d r)
)

;;; (setq rtn (QSS_FindFiles '("c:/temp/lisp") '("*.lsp" "*.txt")))
(defun QSS_FindFiles (folder-list extension-list / folder result result-list status)
  ;;; folder-list is list of all (sub)folders to scan , make sure all folders end with "/"
  (setq folder-list (acad_strlsort (mapcar 'vl_path folder-list)))
  (foreach folder folder-list
    (foreach ext extension-list
      (if (vl-consp (setq result (mapcar '(lambda (x) (strcat folder x))(vl-directory-files folder ext 1))))
        (setq result-list (append result-list result))
      )
    )
    ;;; clear previous status
    (start_image "the_bar")(fill_image 0 0 (dimx_tile "the_bar") (dimy_tile "the_bar") 141)(end_image)
    ;;; update status message
    (setq status (strcat "   ( " (setq *spin* (Spinbar *spin*)) " ) Scanning for files : " (itoa (length result-list))))
    (set_tile "the_bar" status)
  )
  result-list
)

; funny little indicator found in StripMtext.lsp
;(princ (strcat "\r (" (setq s (Spinbar s)) ") Files : " (itoa (setq i (1+ i))) "\t\t"))
(defun SpinBar (spin) (cond ((= spin "\\") "|") ((= spin "|") "/") ((= spin "/") "-") (t "\\")))

;;; ---------------------------------------------------- End of Progress Bar Section -------------------------------------------------- ;;;

(princ "\nRlx May'26 - Type QSS for main function or test1 for test function (all text from all dwgs in c:/temp/lisp/")

Most info included in lisp file. Just a quick string search for lsp, txt & dwg files.

App is still in beta and hasn’t been field tested yet. Still working on the ignore case & whole word options.

IT killed my Total Commander so had to write my own search engine

Start with QSS , select folder , extension like lsp,dwg and search string like Rlx

Type in extensions like lsp,txt (with comma) and for text use pipe symbol like Rlx|Dragon

for now only lsp,txt and dwg are supported , haven't been able to make it work on pdf

 

 

Result is shown in list box. You can select item and open.

If item is lsp or txt , notepad will start.

If item is dwg , app stops and opens dwg (load and save buttons not working yet, not sure I need them.

 

 

 

Edited 1 hour ago by rlx