Leaderboard

;;; 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 ;;; Excel xlApp xlWorkbooks xlWorkbook xlSheets ;;; 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))) ;;; release Excel (Exit_Excel) ) ;;; ------------------------------------------------------ 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)))) ;;; excel : Scan_Excel returns T or nil if regex pattern is found ((wcmatch ext "*`.xls,*`.xlsx") (if (and (Scan_Excel fn) (not (member fn hit-list))) (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 pattern ingnoreCase global 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 s) :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) ;;; (re)init regex pattern (QSS-Search-String-Filter) is something like "Fikkie|Rlx" (setq pattern QSS-Search-String-Filter global T) (if (eq QSS-Case-Sensitive "1")(setq ignoreCase nil)(setq ignoreCase T)) (InitRegExp pattern ignoreCase global) ;;; go through all document objects and retrieve textstring, return as list or test with regex (pat-p) (setq blocks (vla-get-blocks doc)) (if (/= pat "") (progn (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)) (if ral result (pat-p pattern 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 --- ;;; ;;; --- Excel ---------------------------------------------------- Excel ---------------------------------------------------- Excel --- ;;; (defun Init_Excel () (or xlApp (setq xlApp (vlax-get-or-create-object "Excel.Application"))) (vla-put-visible xlApp :vlax-false) ) (defun Exit_Excel () (if xlApp (progn (vl-catch-all-apply 'vlax-invoke-method (list xlWorkbook 'Close :vlax-false)) ;(vlax-invoke-method xlWorkbook 'Close :vlax-false) ;;; close workbook without saving ;(vlax-invoke-method xlApp 'Quit) ;;; may want to skip this because it closes all workbooks (vlax-release-object xlSheets) ;;; ok to release (vlax-release-object xlWorkbook) ;;; ok to release (vlax-release-object xlApp) ;;; ok to release ) ) ) ;;; create range letters "A1:" + Letter & number like "A1:Z10" (defun _cl (i / n) (if (< i 27)(chr (+ 64 i))(if (= 0 (setq n (rem i 26))) (strcat (_cl (1- (/ i 26))) "Z")(strcat (_cl (/ i 26))(chr (+ 64 n)))))) ;;; retrieve all values from Excel workbook (defun Scan_Excel (fn / f xlUsedRange rows xlValue _safearray tmp-lst result excel-range excel-used-range excel-max-row excel-max-column excel-max-range excel-variant excel-value excel-to-list l2 l3 pattern ignoreCase global) ;;; just to make sure regex is up and running (or RegExp (setq RegExp (vlax-create-object "VBScript.RegExp"))) ;;; 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 s) :vlax-true))) l)) ;;; (re)init regex pattern (QSS-Search-String-Filter) is something like "Fikkie|Rlx" (setq pattern QSS-Search-String-Filter global T) (if (eq QSS-Case-Sensitive "1")(setq ignoreCase nil)(setq ignoreCase T)) (InitRegExp pattern ignoreCase global) (if (and fn (string-p fn) (setq f (findfile fn))) (progn (Init_Excel) (setq xlWorkbooks (vlax-get-property xlApp 'Workbooks)) (setq xlWorkbook (vlax-invoke-method xlWorkbooks 'Open f)) (setq xlSheets (vlax-get-property xlWorkbook 'Sheets)) (vlax-for xlSheet xlSheets (setq xlUsedRange (vlax-get-property xlSheet 'UsedRange)) ;;; Set limits on number of rows, not sure what size would be to much for AutoCad to handle (setq rows (vlax-get-property (vlax-get-property xlUsedRange 'Rows) 'Count)) (if (< rows 500000) (progn ;(setq xlValue (vlax-get-property xlUsedRange 'Value)) ;(setq _safearray nil tmp-lst nil) ;(if (= (type xlValue) 'variant) (setq _safearray (vlax-variant-value xlValue))) ;(if (= (type _safearray) 'safearray) (setq tmp-lst (vlax-safearray->list _safearray))) (and (setq excel-variant (vlax-get-property xlUsedRange 'Value)) (setq excel-value (vlax-variant-value excel-variant)) (setq excel-to-list (vlax-safearray->list excel-value)) (setq tmp-lst (vl-remove nil (mapcar '(lambda (x) (vl-remove nil (mapcar '(lambda (y / val) (setq val (vl-catch-all-apply 'vlax-variant-value (list y))) (if (vl-catch-all-error-p val) nil val) ) x) ) ) excel-to-list ) ) ) (setq result (append result tmp-lst)) ) ) (princ (strcat "\nSkipped " (vl-filename-base fn) " Tab '" (vlax-get-property xlSheet 'Name) "' : to many rows (" (itoa rows) ").")) ) (vlax-release-object xlUsedRange) (vlax-release-object xlSheet) ) (vlax-invoke-method xlWorkbook 'Close :vlax-false) ) ) ;;; merge list of lists ( (...) (...) ...) -> (... ... ...) -> (setq l2 (apply 'append result)) ;;; make sure all elements are string -> (setq l3 (mapcar 'vl-princ-to-string l2)) ;;; test if pattern is found in result list , returns T or nil (if (vl-consp result) (pat-p pattern (mapcar 'vl-princ-to-string (apply 'append result)))) ) ;(setq l2 (apply 'append (mapcar '(lambda (x)(mapcar '(lambda (y)(append x y)) a)) b))) (defun c:test3 () (if (Scan_Excel "c:/temp/test.xlsx") (alert "Pattern found in c:/temp/test.xlsx") (alert "Pattern found in c:/temp/test.xlsx"))) ;;; --- Excel ---------------------------------------------------- Excel ---------------------------------------------------- Excel --- ;;; ;;; -------------------------------------------------- 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.

As usual this was born out of necessity. Had a 46Mb pdf , no tools on work laptop to convert it because also no adobe (reader only). PdF was all images so AutoCad pdf attach / import won't work either. Have a (legal) tool on my own computer but pdf wouldn't fit through the mail because of IT limitations. We used to have something like One-drive / Sharepoint but also blocked now , so I wrote this app. It chops up pdf in to 10MB pieces (or any size you want) , it can also email them at the same time and at the other end of the line you can put the pieces back again with the same app. So if your IT department tries to make your life a living hell , hell , maybe this app can give you some relief. RlxSplit.lsp

@PaulyPHI Give this a try.SetPlineZ_Updated.lsp

Indeed, if the block has attributes, (entmod) becomes more complicated: it requires going through transformation matrices and applying them to the attributes. The move command would be simpler... Here is the mhupp code adapted for proper operation: Merits to Mhupp for his code ;;----------------------------------------------------------------------------;; ;; Modify Text or Blocks to align Horozontal or Vertical ;; https://www.cadtutor.net/forum/topic/99091-i-need-a-lisp-to-align-blocks-and-texts-vertically/ (defun C:ATB () (C:AlignTextBlock)) (defun C:AlignTextBlock (/ vars vals pt1 pt2 vector mode ent ed pt newpt) (vl-load-com) (setq vars '(OSMODE ORTHOMODE) vals (mapcar 'getvar vars) ) (mapcar 'setvar vars '(0 1)) (setq pt1 (getpoint "\nAlignment Point: ")) (setq pt2 (getpoint pt1 "\nSelect Horozontal or Vertical:")) (setq vector (mapcar '- pt2 pt1)) (if (eq (car Vector) 0.0) (setq mode 'V) (setq mode 'H)) (while (setq ss (ssget '((0 . "TEXT,INSERT")))) (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) (setq ed (entget ent) pt (cdr (assoc 10 ed)) newpt (if (eq mode 'V) (list (car pt1) (cadr pt) (caddr pt)) (list (car pt) (cadr pt1) (caddr pt))) ) (vla-Move (vlax-ename->vla-object ent) (vlax-3d-point pt) (vlax-3d-point newpt)) ; (if (or (not (assoc 11 ed)) (eq (cdr (assoc 11 ed)) '(0.0 0.0 0.0))) ;test if 11 doesnt exist or is 0,0,0 ; (setq ed (subst (cons 10 newpt) (assoc 10 ed) ed)) ; (setq ed (subst (cons 11 newpt) (assoc 11 ed) ed)) ; ) ; (entmod ed) ) ) (mapcar 'setvar vars vals) (princ) ) (princ "\nAlignTextBlock Lisp Loaded") (princ "\nType ATB or AlignTextBlock to run command")

Haven't checked in a while, but we can't receive any .zip, .rar, etc. in emails here, but can send them, which is useless if sending internally. They had some ridiculously low email attachment file sizes when I first came here, I got them to go to 10MB, that's most likely what it is now. I put large files to share on the network and send a link (which IT has it where it cannot be clicked on), either they figure out how to get it or they don't. Being retirement age has it's perks.

Reminds me of when I had to move a file before networking or USB drives. had to use winrar and split up the zip file between 12 floppy disks! Was curious and it only took 17 lines of code in python lol minus the emailing and join parts.

@darshjalal Nice work! Your added Automatic mode, and the code to strip numbers out of the text is over and above!

@PaulyPHI Here is a quick walk-though: This uses Visual LISP to pull the text string from the selected object and convert it to a real number. See the added comments below. (if (and ;; Logical AND = All conditions must be met. ;; 1) an object must be selected. (setq es (entsel "\nSelect Text Object: ")) ;; 2) The selected object must have a text string property, i.e. TEXT, MTEXT, ATTRIBUTE, MLEADER, etc. (vlax-property-available-p (vlax-ename->vla-object (car es)) 'TextString) ;; 3) Retrieve the textsting value if the above conditions are met. (setq newZ (vla-get-textstring (vlax-ename->vla-object (car es)))) ;; 4) The textstring value must evaluate to greater than 0 when converted to a real number. This only works if the text is numerical. (> (setq newZ (distof newZ)) 0.0) ) ;; if all conditions are met, then continue to the (progn) block that performs the changes.

Welcome. To make a cleaner look I would make a master Chart (or multiple BH SW MW or by area with a box around them) with all the relative call outs. this would allow a larger view of the area. eliminate the use/need of leaders that aren't really doing anything but cluttering the drawing. -edit Then updating would be adding borehole location and adding to the chart.

Don't know what is going on about Textexp but here is a favour for you. I just made A-Z 0-9 exploded. Convert to correct plines then can extrude into a solid say 1 unit high, will need to check the 36 shapes. The sample dwg really needs more thought say text size =1 and height equal say 0.1. It took about 10 minutes to make these. With a bit of practice much faster and use other fonts. You can use presspull to change height. BUT SET TEXT HEIGHT CORRECT BEFORE EXTRUDE. Oh yeah why do you have units set to Architectural when your talking mm ? new block.dwg

Ok I used Txtexp on "MACEY", then went to a 3d view so could see what was going on VPOINT -1,-1,-1. You have to check that all the objects that appear are plines I had to join the little "A" triangle. Ok extruded the base 1.5 Extruded the circles 2.5, then unionid both, to base, subtracted the inner circle from the new solid. Extruded the ""M" 4.5 then did a union again. Extruded the two parts of the "A" unioned together with base then subtracted the inner triangle, You can see the progress. What you want is not a single step but rather multiple steps, lastly can export the STL file. Once you get the hang of extruding, subtrcat and union you can do multiple objects at one time. This is a bit rough as a solid and can be done better, by moving the text to a Z matching base height before you start.

PETA-INSERT ELEVATIONS FROM TEXTS INSIDE THE CLOSED OR OPEN POLYINE.LSP Try this one too

The equal linetype as supplied is just a dashed linetype that has a length of one unit and a gap of one unit. By setting its LTSCALE to the length of a pipe you can get an idea of the number of pipes involved. I have somewhere also convert an existing line to two lines as per right hand image, The GIS used to dump out a single line on a size layer so we wanted 2 dashed lines to imply existing drainage. Will try to find I think that is what you want.

This code is so helpful to convert texts or mtexts to mleader. In the attachments the lisp file and cad file that has the problem I tied to solve. The cad file contains a huge amounts of elevations as texts and leaders that are exploded for landscape work , therefore this lisp can help with case like this Regards TBC- JOIN TEXT AND POLYLINES AND CONVERT THEM TO MLEADER OR MAKE IT MANUALLY.lsp BR FIN LVLS-1.dwg

Before I used this : (defun GetFolder ( m / f s) (if (and (setq s (vlax-create-object "Shell.Application")) (setq f (vlax-invoke s 'browseforfolder 0 m 65536 "")))(setq f (vlax-get-property (vlax-get-property f 'self) 'path)) (setq f nil))(vl-catch-all-apply 'vlax-release-object (list s)) f) (defun wait (sec / stop)(setq stop (+ (getvar "DATE") (/ sec 86400.0)))(while (> stop (getvar "DATE")))) (defun findstring ( / a b c d e) (setq a (GetFolder "Select folder for string search")) (setq b (getstring "\nEnter string to search for : " T)) (setq c (getstring "\nFile extension (lsp) : ")) (if (eq c "") (setq c "lsp")) (setq d (strcat a "\\result.txt")) (setq e (strcat "findstr /i /s \"" b "\" " a "\\*." c " > " d)) (command "shell" e) (gc)(gc) ;;; natural delay for system to clear cache and write file to disk (alert "search completed") (startapp "notepad" d) (princ) ) (defun c:dfs ()(findstring)) (defun c:t1 ()(findstring)(princ)) This code only works for text based files. Have updated code in my first post with Excel support. Valid extensions are now lsp , txt , dwg , xls and xlsx I have a license for able2extract on my home computer and also written something that uses pdfattach and import for readable pdf's. Though I can take that route, it's not like shoot & forget , often more than one step is needed. But it is what it is... most pdf's I get are pretty poor quality , some by accident and some not because a 3rd party wants you as a returning client if you know what I mean.

I meant to mention adding the (\U+200A). IIRC it's called a nonbreaking space. "Hairspace" sounds better IMO. I didn't try this, but one article mentioned to "Save As" or "Export to" PDF to kill the hyperlinks. My AutoCAD 2026 has the option to check Include Hyperlinks under PDF Options on the plot manager.

ah yes. https://www.cadtutor.net/forum/topic/98598-just-a-funny-basic-toolbar/

Try this also. Seemed to work and makes a vector list code of objects. VECTORIZE.lsp

That would be The Dragon, RLX maybe? He had a menu but not sure if that is the one you're thinking off? (I was impressed but been too busy this year to get into using it)

Didn't someone have a lisp that created a menu system in model space ? on the right side of the current view.

Still starting from the mhupp code, I think this corresponds to your request: align all the blocks to the position of a block. Same for text or mtext. (defun C:ABC ( / vars vals ss ssref pt_ref pt2 vector mode ent ed pt newpt) (vl-load-com) (setq vars '(OSMODE ORTHOMODE) vals (mapcar 'getvar vars) ) (mapcar 'setvar vars '(0 1)) (princ "\nSelect Block or Texte.") (while (null (setq ss (ssget '((0 . "*TEXT,INSERT")))))) (princ "\nSelect ONE texte or block to align selection") (while (null (setq ssref (ssget "_+.:E:S" '((0 . "*TEXT,INSERT")))))) (setq pt_ref (cdr (assoc 10 (entget (ssname ssref 0))))) (setq pt2 (getpoint pt_ref "\nSelect Horozontal or Vertical:")) (setq vector (mapcar '- pt2 pt_ref)) (if (eq (car Vector) 0.0) (setq mode 'V) (setq mode 'H)) (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS))) (setq ed (entget ent) pt (cdr (assoc 10 ed)) newpt (if (eq mode 'V) (list (car pt_ref) (cadr pt) (caddr pt)) (list (car pt) (cadr pt_ref) (caddr pt))) ) (vla-Move (vlax-ename->vla-object ent) (vlax-3d-point pt) (vlax-3d-point newpt)) ) (mapcar 'setvar vars vals) (princ) )

I Just try to avoid using command. apparently their is a bug in autocad 2026 and newer that balloons lisp to 276 seconds when it only took .24 second in older versions. just figured everything contained in the block id would move when updating. cant test right but does adding the 66 . 0 exclude single text outside of blocks? vla-move works for me keep it simple.

@mhupp If you want to keep (entmod) in your code and make it efficient, you can refine your filter (ssget) to exclude blocks with attributes. (setq ss (ssget '((0 . "TEXT,INSERT") (66 . 0))))

notice your lisp name is MoveLayerAllLayouts that mean other tabs other than model? ssget "_X" wont pick up things on other tabs if they are on that layer. So if your moving everything might assume your deleting the old layer. if that's the case just rename it. no need to mess with ssget and will pick up everything. (vl-cmdf "_.-Rename" "LA" old new)

Using @BIGAL suggestion for ssget to only pick up text and blocks set in a while loop so you can align multiple things to the same axis. also added a visual to choose between horizontal or vertical alignment. AlignT&B.lsp

Very quickly try these changes: (setq alpty (cadr alpt)) ---> (setq alptx (car alpt)) (setq newpt (list inptx alpty)) --> (setq newpt (list alptx inpty))

@Tsuky works as well, not sure what @sd2006 is struggling with. The one I posted works the same as the OP's in first post for horizontal align, I just added the vertical align and some error checking. Home today, so also tested in AutoCAD 2000i.

Copy what @SLW210 posted in the other thread into a text file save it as .lsp and load that instead of abc.lsp. The command to type to run SLW210's Lisp is "AlignXY"

You have a topic on this lisp already. please take the time to read it. Bạn đã có một chủ đề về Lisp này rồi. Xin hãy dành chút thời gian để đọc nó.

Nice code SLW210. I did get the error that "acad" is a protected symbol, so its better to use a different name for that one. The code worked fine regardless. We can also do the same thing with entmod: (defun c:unlimitedmleaders (/ e enx) (foreach e (vl-remove-if-not (function (lambda (a) (= (car a) 350))) (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE") ) (setq enx (entget (cdr e))) (entmod (subst '(90 . 0) (assoc 90 enx) enx)) ) (princ) )

@mhupp's LISP works for me, but I took a stab at it anyway. I just tweaked the original abc.lsp, I would prefer if you would post a link to the original so I can properly credit the author. For more information, Kent Cooper has quite a few LISPs for aligning blocks for certain and probably (M)Text, etc. (as well as sorting spacing etc.) on the Autodesk Forums, they should be easy to locate. This worked on your provided drawing as well as one I made for test with Polylines, Lines, Blocks, Mtext, Text and Attributes. ;;; Align selected objects in X or Y direction with reference object. | ;;; | ;;; https://www.cadtutor.net/forum/topic/99091-i-need-a-lisp-to-align-blocks-and-texts-vertically/ | ;;; | ;;; Modified from the provided abc.lsp (author unknown) by SLW210 (a.k.a. Steve Wilson) | ;;; | ;;; Was horizontal only, added vertical align option, error and undo. | ;;; | ;;; *****************************************************************************************************| (defun c:AlignXY (/ *error* OS mode ss albl alpt alptx alpty ctr ename inpt inptx inpty newpt olderr ) ;; Error handler (setq olderr *error*) (defun *error* (msg) (if (/= msg "Function cancelled") (princ (strcat "\nError: " msg)) ) (if OS (setvar "OSMODE" OS) ) (command "_.UNDO" "_End") (setq *error* olderr) (princ) ) ;; Save and set system vars (setq OS (getvar "OSMODE")) (setvar "OSMODE" 0) ;; Start UNDO group (command "_.UNDO" "_Begin") ;; Ask user for alignment direction (initget "Horizontal Vertical") (setq mode (getkword "\nAlign [Horizontal/Vertical] <Horizontal>: ")) (if (null mode) (setq mode "Horizontal") ) ;; Select objects (princ "\nSelect blocks or text to align evenly: ") (if (not (setq ss (ssget))) (progn (princ "\nNothing selected.") (*error* "Function cancelled") (exit) ) ) ;; Select reference object (if (not (setq albl (entsel "\nSelect reference text or block: ")) ) (progn (princ "\nNo reference selected.") (*error* "Function cancelled") (exit) ) ) (setq albl (car albl)) (setq alpt (cdr (assoc 10 (entget albl)))) (if (not alpt) (progn (princ "\nInvalid reference object.") (*error* "Function cancelled") (exit) ) ) (setq alptx (car alpt)) (setq alpty (cadr alpt)) ;; Loop through selection (setq ctr 0) (while (setq ename (ssname ss ctr)) (setq inpt (cdr (assoc 10 (entget ename)))) (if inpt (progn (setq inptx (car inpt)) (setq inpty (cadr inpt)) ;; Decide new point (cond ((= mode "Horizontal") (setq newpt (list inptx alpty)) ) ((= mode "Vertical") (setq newpt (list alptx inpty)) ) ) (command "move" ename "" inpt newpt) ) ) (setq ctr (+ ctr 1)) ) ;; End UNDO group cleanly (command "_.UNDO" "_End") ;; Restore vars and error handler (setvar "OSMODE" OS) (setq *error* olderr) (prompt "\nAlignment complete.") (princ) )

Perhaps this would help after you determine the primary dimensions of desired ellipsoid.

Use my above lisp AlignTextBlock that has @Tsuky fix. align.mp4

added a "*" to ssget to pick up mtext or text. updated the foreach to pull the vla-objects name from the selection set. ;;----------------------------------------------------------------------------;; ;; Modify Text or Blocks to align Horozontal or Vertical ;; https://www.cadtutor.net/forum/topic/99091-i-need-a-lisp-to-align-blocks-and-texts-vertically/ (defun C:ATB () (C:AlignTextBlock)) (defun C:AlignTextBlock (/ vars vals pt1 pt2 vector mode ent ed pt newpt) (vl-load-com) (setq vars '(OSMODE ORTHOMODE) vals (mapcar 'getvar vars) ) (mapcar 'setvar vars '(0 1)) (setq pt1 (getpoint "\nAlignment Point: ")) (setq pt2 (getpoint pt1 "\nSelect Horozontal or Vertical:")) (setq vector (mapcar '- pt2 pt1)) (if (eq (car Vector) 0.0) (setq mode 'V) (setq mode 'H)) (while (setq ss (ssget '((0 . "*TEXT,INSERT")))) (foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS)))) (setq pt (vlax-safearray->list (vlax-variant-value (vla-get-InsertionPoint obj))) newpt (if (eq mode 'V) (list (car pt1) (cadr pt) (caddr pt)) (list (car pt) (cadr pt1) (caddr pt))) ) (vla-Move obj (vlax-3d-point pt) (vlax-3d-point newpt)) ) ) (mapcar 'setvar vars vals) (princ) ) (princ "\nAlignTextBlock Lisp Loaded") (princ "\nType ATB or AlignTextBlock to run command")

i try to write an extra function to split the area from a polyline like the image but i can not understand how he do this (defun userpt ( / pl vlist pts ptb p1 p2 dir len perp tval korak min-korak iter max-iterations big pA pB vertsA vertsB v i areaA target) (setq pl (car (entsel "\nSelect Polyline: "))) (if (not pl) (progn (princ "\nNo selection.") (exit)) ) (setq vlist (getver_lwpoly pl)) (if (< (length vlist) 3) (progn (princ "\nInvalid polygon.") (exit)) ) (setq p1 (nth 0 vlist)) (setq p2 (nth 1 vlist)) (setq dir (mapcar '- p2 p1)) (setq len (distance p1 p2)) (setq dir (mapcar '(lambda (x) (/ x len)) dir)) (setq perp (list (- (cadr dir)) (car dir) 0.0)) (setq pts (getpoint "\nFirst point: ")) (setq ptb (getpoint "\nSecond point: ")) (command "_area" "e" pl) (setq target (/ (getvar "area") 2.0)) (setq tval 0.0) (setq korak 1.0) (setq min-korak 0.0001) (setq max-iterations 60) (setq iter 0) (setq big 100000.0) (princ "\nSolving...") (while (< iter max-iterations) (setq pA (mapcar '+ pts (mapcar '(lambda (x) (* x big)) dir))) (setq pB (mapcar '- pts (mapcar '(lambda (x) (* x big)) dir))) (setq pA (mapcar '+ pA (mapcar '(lambda (x) (* x tval)) perp))) (setq pB (mapcar '+ pB (mapcar '(lambda (x) (* x tval)) perp))) (setq vertsA '()) (setq vertsB '()) (foreach v vlist (setq i v) (if (> (+ (* (- (car i) (car pA)) (- (cadr pB) (cadr pA))) (* (- (cadr i) (cadr pA)) (- (car pA) (car pB)))) 0) (setq vertsA (cons i vertsA)) (setq vertsB (cons i vertsB)) ) ) (setq areaA 0.0) (foreach v vertsA (setq areaA (+ areaA (car v))) ) (if (< areaA target) (setq tval (+ tval korak)) (setq tval (- tval korak)) ) (setq korak (/ korak 1.2)) (if (< korak min-korak) (setq korak min-korak) ) (setq iter (1+ iter)) ) (princ "\nCreating polygons...") ;; polygon A (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length vertsA)) (cons 70 1) ) (mapcar '(lambda (p) (cons 10 p)) vertsA) ) ) ;; polygon B (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length vertsB)) (cons 70 1) ) (mapcar '(lambda (p) (cons 10 p)) vertsB) ) ) (princ "\nDone .") (princ) ) Can any one help ? Thanks

I used to use JTB Align Plus - JTB World. I need IT to reinstall, haven't needed it recently, so I'll probably wait until I need, but pretty sure it will do everything the OP wants and more. I have a LISP, but IIRC it may need a lot of tweaking for the OPs usage.

I ran into something similar with batch DXF → DWG. One thing to watch is SAVE vs SAVEAS — in batch, SAVE doesn’t always behave as expected, especially if the drawing has no proper name yet. Also, FILEDIA needs to be set to 0 or the process can stop on dialogs. For small batches, the LISP solutions above should work fine. For larger batches, I found using accoreconsole with a simple script more reliable.

(setq oldLayer (getstring T "\nEnter the name of the layer to move FROM: ")) ;; Prompt for target layer (setq newLayer (getstring T "\nEnter the name of the layer to move TO: "))

im guessing the text is left justified and your wanting them to be aligned vertical down the center. need to update line 21 & 22 with code above. and make text center or middle justified. -edit or all the same justification. The text justification effects how the text align with the point and each other same with blocks. The insertion point is what is being updated. its the grip that shows when block is selected. --edit edit The left pic shows the grips that will be aligned to. (green dots) the right pic because they are middle justified will use the middle grip points instead of the bottom right for allignment.

You need to check if the text style has a set height because the options in the TEXT command are not the same. (defun C:ah () (hatcharea)) (defun hatcharea ( / ss area i eo pt) (setq ss (ssget '((0 . "hatch"))) area 0 i 0 ) (cond ((and(and ss) (> (sslength ss) 0)) (repeat (sslength ss) (setq eo (vlax-ename->vla-object (ssname ss i))) (setq area (+ area (vlax-get eo 'Area))) (setq i (+ i 1)) ) (while (not pt)(setq pt (getpoint "\nSelect area text insertion point >"))) (setq area (/ area 1000000.)) (if (zerop (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE"))))) (command "_.text" pt "" "" (strcat "" (rtos area 2 2) " m²")) (command "_.text" pt "" (strcat "" (rtos area 2 2) " m²")) ) ) ) (princ) )

The block att misaligned text.

Was looking at the code and that cond is a bit overkill swapped it out with one line if. newpt (if (eq mode 'V) (list (car pt1) (cadr pt) (caddr pt)) (list (car pt) (cadr pt1) (caddr pt))) I also notice entmod doesn't like text that are not left justified. -edit Apparently text only uses 10 to locate if its left-justified and 11 for everything else. so need to test for that and update either 10 or 11. (if (or (not (assoc 11 ed)) (eq (cdr (assoc 11 ed)) '(0.0 0.0 0.0))) ;test if 11 doesnt exist or is 0,0,0 (setq ed (subst (cons 10 newpt) (assoc 10 ed) ed)) (setq ed (subst (cons 11 newpt) (assoc 11 ed) ed)) ) (entmod ed)

From now own it would be appreciated if you would provide a proper title to your threads. I renamed this one for you. Also, when posting a code, as mentioned by @mhupp, use Code Tags (<> in the editor toolbar) Also, when posting a "found" code, please provide the source where it can be found.

Another suggestion (setq ss (ssget (list (cons 0 "TEXT,INSERT"))))

Post a sample block or drawing also use the <> when posting code.

Hello, for a project I needed to find the shortest way between two points in a network, so I searched for a pathfinding algorithm in AutoLISP. Since I did not find anything - here comes my implementation of the A* pathfinding algorithm. (If you don't know what A* is - I got my information here: http://en.wikipedia.org/wiki/A*_search_algorithm) The program finds the shortest way in a network of polylines between two points, the polylines representing the paths you are allowed to move along. Two polylines are considered connected if one of their vertices match. The resulting path is returned as a new polyline. The program and a test.dwg are attached to this post. I would like to extent the network/edges in a way, that polylines are also considered connected if the vertice of one of them is on the line of another. I could use some help with that. I hope this is useful for someone. astar_01.lsp test_01.dwg

I implemented astar using a heap instead of the dictionnary proposed by @GLAVCVS. Safearray is used to simulate the heap. Was done with prompt in Google AI. Results the heap is faster specially if the graph is bigger. ;; ; ;; c:A* by ymg ; ;; Astar implemented with a Heap instead of a dictionnary ; ;; Edges of the Graph are drawn on layer identified by Golbal #Edgeslay ; ;; ; ;; Edges can be lines, lpolylines or 3dpolylines ; ;; You select Start and End points. Shortest is then found and drawn as a ; ;; 3D Polylines on layer, color and lineweight chosen via Global vars ; ;; found at beginning of this routine ; ;; ; ;; Heap has a faster running time than the dictionnary and list approach ; ;; as the size of the graph grows. ; ;; ; (defun c:A* (/ ss graph openH gScore cameFrom found cur curPt curK sNode sKey neighbor nKey t_g val oldG oldCF Startp Endp d minD en param endpar p1 p2 path k link pt i ti) (vl-load-com) (or #acdoc (setq #acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler '("CLAYER" "OSMODE" "CMDECHO" "DIMZIN")) (setvar 'CMDECHO 0) (setvar 'OSMODE 1) (setq #Edgelay "Edges" #Pathlay "Path" #Pathcol 1 #Pathlwt 70 #Hptr 0 ) ;; Selecting set of entities defining edges of graph. (if (not (setq ss (ssget "X" (list '(0 . "LINE,LWPOLYLINE,POLYLINE") (cons 8 #Edgelay))))) (progn (alert (strcat "\nError: No entities found on layer " #Edgelay)) (exit) ) ) (vla-startundomark #acdoc) ;; Geting Start and End points. (Use snap to endpoint) (setq Startp (getpoint "\nPick Start Point: ")) (mk_circle Startp 7.5 #Pathcol) (setq Endp (getpoint "\nPick End Point: ")) (mk_circle Endp 7.5 3) (setq ti (getvar 'MILLISECS)) ;Timer for execution time ; Building Graph... (setq graph nil i 0) (repeat (sslength ss) (setq en (ssname ss i) ent (entget en) param 0 endpar (vlax-curve-getEndParam en) i (1+ i) ) (while (< param endpar) (if (= (cdr (assoc 0 ent)) "LINE") (setq p1 (vlax-curve-getstartpoint en) p2 (vlax-curve-getendpoint en) param (1+ endpar) ) (setq p1 (vlax-curve-getPointAtParam en param) p2 (vlax-curve-getPointAtParam en (setq param (1+ param))) ) ) (setq k1 (pt->key p1) k2 (pt->key p2) graph (update-g graph k1 p1 p2) graph (update-g graph k2 p2 p1) ) ) ) (setq minD 1.7e308) ; Initialize to infinity (foreach entry graph (if (< (setq d (distance (cadr entry) Startp)) minD) (setq minD d sNode entry) ) ) (setq sKey (car sNode) openH (heap:new (length graph)) gScore (list (cons sKey 0.0)) cameFrom nil found nil ) (heap:push openH (distance (cadr sNode) Endp) (cadr sNode)) (setq gbti (- (getvar 'MILLISECS) ti)) ;Start of Pathfinding... (while (and (> #Hptr 0) (not found)) (setq cur (heap:pop openH) curPt (cdr cur) curK (pt->key curPt) ) (if (< (distance curPt Endp) 0.1) (setq found T) (foreach neighbor (cddr (assoc curK graph)) (setq nKey (pt->key neighbor) val (assoc curK gScore) t_g (+ (cdr val) (distance curPt neighbor)) ) (if (or (null (setq oldG (assoc nKey gScore))) (< t_g (cdr oldG))) (progn (if oldG (setq gScore (vl-remove oldG gScore))) (setq gScore (cons (cons nKey t_g) gScore)) (if (setq oldCF (assoc nKey cameFrom)) (setq cameFrom (subst (cons nKey curPt) oldCF cameFrom)) (setq cameFrom (cons (cons nKey curPt) cameFrom)) ) (heap:push openH (+ t_g (distance neighbor Endp)) neighbor) ) ) ) ) ) ;; Result Handling (if found (progn (setq path (list curPt) k curK ) (while (setq link (assoc k cameFrom)) (setq pt (cdr link) k (pt->key pt) path (cons pt path) ) ) (mk_3dp path) ) (princ "\nNo path found.") ) (vla-endundomark #acdoc) (setq totaltime (- (getvar 'MILLISECS) ti)) (princ "\n ----- A* Optimized With Gemini ----- ") (princ (strcat "\n Graph Size: " (itoa (length graph)) " nodes")) (princ (strcat "\n Graph Building Time: " (itoa gbti) " ms.")) (princ (strcat "\n Pathfinding Time: " (itoa (- totaltime gbti)) " ms.")) (princ (strcat "\nTotal Execution time: " (itoa totaltime) " ms.")) (*error* nil) ) ;; ; ;; ERROR HANDLING & SYSTEM UTILITIES ; ;; ; ;; ; ;; set_errhandler by Elpanov Evgenyi ; ;; Captures system variable states into global #varl. ; ;; Argument 'l': List of strings naming system variables. ; ;; ; (defun set_errhandler (l) (setq #varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) l)) ) ;; ; ;; *error* by Elpanov Evgenyi ; ;; Redefines the *error* function and display an error message. ; ;; Restores system variables and handles exit messages. ; ;; ; (defun *error* (msg) (mapcar 'eval #varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (princ) ) ;; ; ;; Heap Abstraction Utilities Using Safearray ; ;; ; ;; ; ;; heap:new ; ;; ; ;; Initializes a Variant Safearray as a Minimum-Heap and set the Heap pointer ; ;; Global Var #Hptr to 0 ; ;; ; ;; Argument: size, Total capacity for the Heap. ; ;; ; ;; Return : Safearray Object ; ;; ; (defun heap:new (size) (setq #Hptr 0) (vlax-make-safearray vlax-vbVariant (cons 0 (max 1 (1- size))) '(0 . 1)) ) ;; ; ;; heap:get ; ;; ; ;; Fetch node data at given index in the heap ; ;; ; ;; Arguments: h, Heap name as a safearray object ; ;; idx, Index of the node ; ;; ; ;; Returns: A dotted pair, (Priority . Point) ; ;; ; (defun heap:get (h idx) (cons (vlax-variant-value (vlax-safearray-get-element h idx 0)) (vlax-safearray->list (vlax-variant-value (vlax-safearray-get-element h idx 1))) ) ) ;; ; ;; heap:set ; ;; ; ;; Writes priority and point into heap at index. ; ;; Arguments: h, heap name ; ;; i, index ; ;; prio, double ; ;; p, point. ; ;; ; (defun heap:set (h i prio p / arr) (setq arr (vlax-make-safearray vlax-vbDouble '(0 . 2))) (vlax-safearray-fill arr (mapcar 'float p)) (vlax-safearray-put-element h i 0 (vlax-make-variant prio vlax-vbDouble)) (vlax-safearray-put-element h i 1 arr) ) ;; ; ;; heap:swap ; ;; ; ;; Swaps two elements the heap ; ;; ; ;; Arguments: h, heap name ; ;; i, index of first element ; ;; j, index of second element ; ;; ; (defun heap:swap (h i j / tp tv) (setq tp (vlax-safearray-get-element h i 0) tv (vlax-safearray-get-element h i 1) ) (vlax-safearray-put-element h i 0 (vlax-safearray-get-element h j 0)) (vlax-safearray-put-element h i 1 (vlax-safearray-get-element h j 1)) (vlax-safearray-put-element h j 0 tp) (vlax-safearray-put-element h j 1 tv) ) ;; ; ;; heap:push ; ;; Adds a node, re-sorts heap via sift-up and adjust the heap pointer ; ;; ; ;; Arguments: h, heap name ; ;; prio, priority ; ;; pt, point ; ;; ; ;; Returns: Value of heap pointer ; ;; ; (defun heap:push (h prio pt / i p) (heap:set h #Hptr prio pt) (setq i #Hptr) (while (and (> i 0) (< prio (car (heap:get h (setq p (/ (1- i) 2)))))) (heap:swap h i p) (setq i p) ) (setq #Hptr (1+ #Hptr)) ) ;; ; ;; heap:pop ; ;; ; ;; Removes root node, re-sorts the heap by sift-down updates #Hptr ; ;; ; ;; Argument: h, heap name ; ;; ; ;; Return: root node as dotted pair (Priority . Point) ; ;; ; (defun heap:pop (h / root size i l r s i-prio l-prio r-prio) (if (> #Hptr 0) (progn (setq root (heap:get h 0) #Hptr (1- #Hptr)) (if (> #Hptr 0) (progn (heap:swap h 0 #Hptr) (setq i 0 size #Hptr) (while (< (setq l (1+ (* i 2))) size) (setq r (1+ l) ;; Get priorities once to avoid redundant safearray lookups i-prio (vlax-variant-value (vlax-safearray-get-element h i 0)) l-prio (vlax-variant-value (vlax-safearray-get-element h l 0)) s l ) ;; Check if right child exists and is smaller than left (if (and (< r size) (< (setq r-prio (vlax-variant-value (vlax-safearray-get-element h r 0))) l-prio)) (setq s r l-prio r-prio)) ;; Update smallest index and priority ;; If smallest child is smaller than current, swap (if (< l-prio i-prio) (progn (heap:swap h i s) (setq i s)) (setq i size)) ;; Else, heap property restored ) ) ) root ) ) ) ;; ; ;; GRAPH & DRAWING UTILITIES ; ;; ; ;; ; ;; pt->key ; ;; Converts 3D point to a string key "X,Y,Z". ; ;; Argument 'p': 3D point list. ; ;; ; (defun pt->key (p) (strcat (rtos (car p) 2 2) " " (rtos (cadr p) 2 2) " " (rtos (caddr p) 2 2))) ;; ; ;; update-g ; ;; Links nodes in graph association list. ; ;; ; ;; Arguments: g, graph list ; ;; k, key ; ;; p, point ; ;; n, neighbor. ; ; ;; ; (defun update-g (g k p n / ex) (if (setq ex (assoc k g)) (subst (append ex (list n)) ex g) (cons (list k p n) g) ) ) ;; ; ;; mk_3dp by Alan J Thompson ; ;; ; ;; Entmakes a 3D Polyline. Global Vars #Pathlay, #Pathcol and #Pathlwt have ; ;; to be set in calling program. ; ;; ; ;; Argument: lst, List of 3D points. ; ;; ; ;; Returns: Entity Name of Polyline ; ;; ; (defun mk_3dp (lst / vtx) (if (and lst (> (length lst) 1)) (progn (entmakex (list '(0 . "POLYLINE") '(10 0. 0. 0.) (cons 8 #Pathlay) (cons 62 #Pathcol) (cons 370 #Pathlwt) '(70 . 8) ) ) (foreach vtx lst (entmakex (list '(0 . "VERTEX") (cons 10 vtx) '(70 . 32) ) ) ) (entmakex '((0 . "SEQEND"))) ) ) ) (defun mk_circle (ctr rad color) (entmakex (list (cons 0 "CIRCLE") (cons 10 ctr) (cons 40 rad) (cons 8 #Pathlay) (cons 62 color) (cons 370 #Pathlwt) ) ) ) (princ "\nCommand A* loaded.") (princ) Astar3dHeap.LSP

I think I chose the wrong version from my test code in the previous release. There are some bugs that affect drawings containing splines. This version should fix those bugs. ;; Pathfinding with the A* algorithm by ymg 22/07/2024 ; ;; ; ;; Revised a prog by HELMUT SCHRÖDER - heschr@gmx.de - 2014-09-14 ; ;; found at Cadtutor.net ; ;; ; ;; Kept the same format for edges list but added lines as valid choice ; ;; Format: (((x1 y1) (x2 y2)) (((x2 y2) (x3 y3))....(xn yn))) ; ;; ; ;; The user is asked to pick a start and an endpoint. ; ;; The program will find the shortest path in a network of connected ; ;; polylines and/or lines and draw a new polyline representing the result. ; ;; ; ;; Two lists of nodes openlst and closelst are created from the above ; ;; mentionned edges list. The format of a node list is: ; ;; (((Point) (Prev Point) Cumulated_Distance Estimated_Total_Distance)...) ; ;; ; ;; Main change from origina are: ; ;; - cons the list instead of append ; ;; - vl-sort the openlist instead of the quicksort ; ;; - Replaced and renamed some vars and subroutine. ; ;; - Added fuzz 1e-4 to all points comparison ; ;; - Change the get_path function ; ;; - Added line as possible edges ; ;; - Added an error handler ; ;; - Added a timer to the search portion of the program ; ;; ; ;; The above changes amounted to an acceleration of about 4x from the ; ;; original program. ; ;; : ;; If you compile this program to a .fas you'll get more than 10x faster. ; ;; ; ;| Added or revised code by GLAVCVS (january 2026) -All set are grouped into one -An associative sparse matrix cell->handles is created for faster cell querying (using new 'addToDict' and 'getCell' functions) -The "edges" list is replaced with the local search retourned by 'getCell' T E S T S ===== fas: 4-5 x faster than previous fas lsp: 7-8 x faster than previous lsp (february 8, 2026): -Added new function '·dist·' for measuring distances of curved segments -Added a new lightweight function 'glvFix' to prevent possible rounding mismatches -Added a new function 'EBiPts' to control obtaining coordinates from LINE and SPLINE objects -Several modifications to include in filters and matrix the necessary compatibility with curved linear objects |; (defun c:A** (/ *error* addToDict getCell upd_openlst in_openlst get_path memberfuzz mk_lwp f3Dpol LM:rtos set_errhandler sspl i startp endp e openlst closelst found acdoc lstClvs Pathlay Pathcol Pathlwt varl node ti ·dist· glvFix ) (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com)) (defun *error* (msg) (if e (if command-s (command-s "_.draworder" e "" "_f") (vl-cmdf "_.draworder" e "" "_f") ) ) (mapcar (function eval) varl) (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*"))) (princ (strcat "\nError: " msg)) ) (vla-endundomark acdoc) (princ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;ADDED by GLAVCVS ;;;Create dictionary (defun addToDict (en / p val id clv i l c a to sp pl) (setq i -1 id (cdr (assoc 5 (setq l (entget en)))) c (= (setq to (cdr (assoc 0 l))) "LINE") sp (= to "SPLINE") pl (= to "POLYLINE")); a 10) (while (setq p (if (and (setq i (1+ i)) (or c sp pl)) (eBiPts en i) (vlax-curve-getPointAtParam en i))) (if (setq val (assoc (setq clv (strcat (itoa (glvFix (car p) 0.0001)) "," (itoa (glvFix (cadr p) 0.0001)) "," (itoa (glvFix (caddr p) 0.0001)))) lstClvs)) (setq lstClvs (subst (append val (list (cons id i))) val lstClvs)) (setq lstClvs (cons (list clv (cons id i)) lstClvs)) ) ) ) (defun ·dist· (r e p1 p2) (if r (vlax-curve-getEndParam e) (abs (- (vlax-curve-getDistAtParam e p1) (vlax-curve-getDistAtParam e p2))))) ;;;return list cell ;;*** Modified to access the new dictionary format *** (defun getCell (pt / val clv lr pr par l c oc p0 p to sp pl) (defun oc (c e i) (if c (cdr (assoc (+ i 10) l)) (vlax-curve-getPointAtParam e i))) (if (setq val (assoc (setq clv (strcat (itoa (glvFix (car pt) 0.0001)) "," (itoa (glvFix (cadr pt) 0.0001)) "," (itoa (glvFix (caddr pt) 0.0001)))) lstClvs)) (foreach par (cdr val) (setq e (handent (car par)) c (= (setq to (cdr (assoc 0 (setq l (entget e))))) "LINE") sp (= to "SPLINE") pl (= to "POLYLINE")) (if (zerop (setq pr (cdr par))) (setq lr (cons (list (cond (c "l") (sp "s") (pl "p")) e pr (1+ pr)) lr)) (setq lr (cons (list (cond (c "l") (sp "s") (pl "p")) e (1- pr) pr) lr) lr (if ((if (or c sp pl) eBiPts vlax-curve-getPointAtParam) e (1+ pr)) (cons (list (cond (c "l") (sp "s") (pl "p")) e pr (1+ pr)) lr) lr) ) ) ) ) ) (defun eBiPts (e pr / v0 v1 lp) (cond ((zerop pr) (vlax-curve-getStartPoint e)) ((= pr 1) (vlax-curve-getEndPoint e))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ; ;; upd_openlst ; ;; ; ;; Each node of the openlst is passed to this sub and we scan the edges list ; ;; to find the corresponding edges. Then both points of the edges are tested ; ;; for equality to the nodes. The fixed cost (distance) is updated and so is ; ;; the estimated total distance. Updates are first put in a temporary node. ; ;; ; ;; We then proceed to test if the temp variable is already in the closelst ; ;; and proceed to the next edge. ; ;; ; ;; If temp is true and temp is not in closelst we go to the recursive sub ; ;; in_openlst which adjust the values and return the updated openlst ; ;; ; ;; Upon return we sort the openlst on smallest estimated distance ; ;; and return the openlst to the main routine ; ;; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun upd_openlst (node endp openlst closelst / lEdges pt fcost p1 p2 d f e r temp) (setq pt (car node) fcost (caddr node) ) (setq lEdges (getCell pt)) (foreach edge lEdges (setq f (if (setq r (member (car edge) '("l" "s" "p"))) eBiPts vlax-curve-getPointAtParam);new e (cadr edge);new pr1 (caddr edge);new pr2 (cadddr edge);new p1 (f e pr1);new p2 (f e pr2);new d (·dist· r e pr1 pr2);new temp nil ) (cond ((equal pt p1 1e-4) (setq temp (list p2 p1 (+ fcost d) (+ fcost d (distance p2 endp)))) ) ((equal pt p2 1e-4) (setq temp (list p1 p2 (+ fcost d) (+ fcost d (distance p1 endp)))) ) ) (if (and temp (not (memberfuzz (car temp) closelst))) (setq openlst (in_openlst temp openlst)) ) ) (vl-sort openlst (function (lambda (a b) (< (cadddr a) (cadddr b))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun in_openlst (node lst) (cond ((not lst) (list node)) ((equal (car node) (caar lst) 1e-4) (if (< (cadddr node) (cadddr (car lst))) (cons node (cdr lst)) lst ) ) (t (cons (car lst) (in_openlst node (cdr lst)))) ) ) ;; ; ;; get_path ; ;; ; ;; Returns The list of points of shortest path found from closelst. ; ;; ; (defun get_path (lst / path) (setq path (list (caar lst)) prev (cadar lst) lst (cdr lst) ) (while (setq lst (memberfuzz prev lst)) (setq prev (cadar lst) path (cons (caar lst) path) ) ) path ) ;; ; ;; memberfuzz by Gile Chanteau ; ;; ; ;; Modified to work with nodes list ; ;; ; (defun memberfuzz (p lst) (while (and lst (not (equal p (caar lst) 1e-4))) (setq lst (cdr lst)) ) lst ) ;; ; ;; f3Dpol ; ;; ; ;; Draw an 3dpolyline given a point list ; ;; ; ;; Will be drawn on layer, lineweight and color defined by Variables ; ;; at beginning of program. ; ;; ; ;;;ADDED by GLAVCVS (defun f3Dpol (pts c / ep ll la e) (setq ep (if (= 1 (getvar (quote cvport))) (vla-get-PaperSpace acdoc) (vla-get-ModelSpace acdoc)) ll (apply (function append) pts) la (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length ll)))) (mapcar (function float) ll)) e (vla-Add3DPoly ep la) ) (vla-put-Color e c) (vla-put-Layer e Pathlay) (vla-put-Lineweight e Pathlwt) (vlax-vla-object->ename e) ) ;; ; ;; mk_lwp ; ;; ; ;; Draw an lwpolyline given a point list ; ;; ; ;; Will be drawn on layer with color and lineweight defined by Variables ; ;; at beginnung of program. ; ;; ; (defun mk_lwp (pl) (entmakex (append (list (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 8 Pathlay) (cons 62 Pathcol) (cons 90 (length pl)) (cons 70 (* 128 (getvar (quote plinegen)))) (cons 370 Pathlwt) ) (mapcar (function (lambda (a) (cons 10 a))) pl) ) ) ) (defun glvFix (r i / f f1) (if (= (setq f (fix r)) (setq f1 (fix (+ r i)))) f f1)) ;; A wrapper for the rtos function to negate the effect of DIMZIN - Lee Mac (defun LM:rtos (real units prec / dimzin result) (setq dimzin (getvar (quote dimzin))) (setvar (quote dimzin) 0) (setq result (vl-catch-all-apply (function rtos) (list real units prec))) (setvar (quote dimzin) dimzin) (if (not (vl-catch-all-error-p result)) result ) ) ;; Error Handler by Elpanov Evgenyi ; (defun set_errhandler (l) (setq varl (mapcar (function (lambda (a) (list (quote setvar) a (getvar a)))) l)) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Change values of following 3 variables to suit your need. ; (setq Pathlay "0" Pathcol 3 ; 1=Red 2=Yellow 3=Green etc. ; Pathlwt 30 ; lineweight for path 0.3 mm ; ) (or acdoc (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))) (set_errhandler (list "clayer" "osmode" "cmdecho")) (setvar (quote cmdecho) 0) (setvar (quote osmode) 1) (setvar (quote lwdisplay) 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (prompt "\nSelect LINE and polygonal POLYLINE network entities...") (if (setq sspl (ssget '((0 . "*LINE")))) (foreach en (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sspl))) (addToDict en) ) ) (initget 1) (setq startp (getpoint "\nPick or specify Start Point : ")) (initget 1) (setq endp (getpoint "\nPick or specify End Point : ")) (setq openlst (list (list startp (list 0.0 0.0 0.0) 0.0 (distance startp endp)))) (vla-startundomark acdoc) (setq ti (getvar (quote millisecs))) (while (and openlst (not found)) (setq node (car openlst)) (if (equal (car node) endp 1e-4) (setq found t closelst (cons node closelst)) (setq closelst (cons node closelst) openlst (upd_openlst node endp (cdr openlst) closelst)) ) ) (if found (if (vl-some (function (lambda (x) (not (equal (last x) 0.0 1e-4)))) (setq path (get_path closelst))) (setq e (f3Dpol path Pathcol)) (setq e (mk_lwp path)) ) (alert "No path was found...") ) (princ (strcat "\nExecution time : " (itoa (- (getvar (quote millisecs)) ti)) " milliseconds...")) (*error* nil) ) PS: As I mentioned earlier, the object representing the route remains the same polyline as in the previous code examples. Therefore, although the calculations did take curved segments into account, the final polyline marking the route will still draw straight segments.

I think it was a Renault car it had only 3 wheel studs so the front hub would look something like that. Note the internal groove for a seal. Thats where the section would show that clearly.

There is also THIS.