Leaderboard

little background on how DWG drawings work or how I understand. When you create or modify anything in a drawing it puts it at the end of drawing list. that is why you can select the last thing with (entlast) The blocks you are inserting is a made up of entity's and when you explode the block its gone but it's entity's are left in the drawing. even if its only one item its now under a different entity name. Your join command is saying join block 1 2 3 4 but you exploded them. you have to build another selection set of those entity's to join. so you create a place holder in the Drawing list with LastEnt insert and explode your block. then with the while its basically saying anything after this point in the list add to selection set SS. then pass the SS to the join command. (setq SS (ssadd)) (setq LastEnt (entlast)) (command "-insert" "*Infil_HL" '(0.0 0.0 0.0) "" "" "") (command "-insert" "*blk2" '(0.0 0.0 0.0) "" "" "") ;ent2 (command "-insert" "*blk3" '(0.0 0.0 0.0) "" "" "") ;ent3 (command "-insert" "*blk4" '(0.0 0.0 0.0) "" "" "") ;ent4 (while (setq LastEnt (entnext LastEnt)) (ssadd LastEnt SS) ) (command "_join" SS) -edit adding * infront of the block name AutoCAD inserts and immediately explodes it in one step.

Added a few options since the first version for those who like to pimp things. Same restrictons as b4 , text display is very basic , keep them short or use wider buttons , background fill is fine for standard drawings sizes , but very large units can take some time so added option in setup dialog to tweak fill percentage. Very small drawings / zoom factor also impacts fill. But then if I have to live with these limits of lisp , so do you. Very satisfying I can tell you. App can be started with c:GrM (Graphic Menu) , you probably want to fill the app list with your favorite lisp routines and app still works by loading 'MyLisp' and then assumes it starts with (c:MyLisp). Haven't tested it on a virgin system yet so hope it runs on first use. App should display toolbar with default settings and enters a grread loop , there you can select button or press S for setup , O to change orientation (left / right / top / center / bottom) and also do some zooming, oh just read the freaking command prompt. One button(key) isn't listed , D , that was for debugging. Just left it there for those who get off pressing buttons. In setup dialog top left will show if debug mode is active. You probably use it once in you life but it could be a nice template for future apps. You also can directly go to setup dialog with (C:GrMS) Well I could go on but what be the fun in that. If I did my work app should explain itself. My reason for making this is that for every job I do I make my tools on the fly and having to edit / recompile my autocad toolbar every freaking time started to irritate me and now I just pimp my own toolbar / app-list (you can save multiple toolbar data files in the app-list dialog) Well , as you should know by now : hope you have fun or else bite me (or your mother in law) Oh , if you choose center orientation I would advise to use the fixed width / height option ... or not , I'm not your mommie ...daddy? ... maybe... 2025-09-07 : updated a couple of first use issues & added 'hotkey' [C]olor to cycle different colors GrM.lsp

(vl-load-com) (defun c:FOO (/ *error* acDoc ss pt y item data blocks) (defun *error* (msg) (if ss (vla-delete ss)) (if acDoc (vla-endundomark acDoc)) (cond ((not msg)) ; Normal exit ((member msg '("Function cancelled" "quit / exit abort"))) ; <esc> or (quit) ((princ (strcat "\n** Error: " msg " ** "))) ; Fatal error, display it ) (princ) ) (if (and (ssget "_:L" '((0 . "INSERT"))) (setq d (getreal "\nEnter Block distance: ")) ) (progn (vla-startundomark (setq acDoc (vla-get-activedocument (vlax-get-acad-object))) ) (vlax-for x (setq ss (vla-get-activeselectionset acDoc)) (setq pt (vlax-get x 'insertionpoint)) (if (setq item (assoc (setq y (cadr pt)) data)) (setq data (subst (cons (car item) (append (cdr item) (list x))) item data) ) (setq data (cons (cons y (list x)) data)) ) ) (if data (foreach item data (setq blocks (vl-sort (cdr item) (function (lambda (a b) (< (car (vlax-get a 'insertionpoint)) (car (vlax-get b 'insertionpoint)) ) ) ) ) ) (setq pt (vlax-get (car blocks) 'insertionpoint)) (foreach block (cdr blocks) (vla-move block (vlax-3d-point (vlax-get block 'insertionpoint)) (vlax-3d-point (setq pt (polar pt 0.0 d))) ) ) ) ) ) ) (*error* nil) ) This works for each group of Blocks at a given Y level, based on the lowest X position in a given row as starting point.

try this : (defun Fill_Toolbar_Background (x- y- x+ y+ c / y vws bgf-fac delta-y) (setq y y- vws (getvar "viewsize") bgf-fac (/ 0.1 (/ (atof GrM-Button-Background-Fill) 100.0))) (setq delta-y (/ vws 1000.0)) (while (<= y y+)(grdraw (list x- y)(list x+ y) c)(setq y (+ y (* delta-y bgf-fac (/ vws start-viewsize)))))) did very little testing though... oh , about the 'duplicated' background fill , although there are two and the first could (should) have been deleted, it doesn't matter because lisp only evaluates the last version. Every new definition overwites the previous one.

you're absolutely right GLAVCVS , took out too much when I cleaned out some obsolete code. Usually I forget the 'void' function but paid special attention I didn't this time. At the expense of rlx_sf this time so it seems. Have done a few changes , renamed orientation to justification (change with letter j / J while menu is displayed) , change (background) color with b (or B) and with keys c / C & r / R decrease / increase columns & rows. Hope all the bugs are dead now... ;;; GrM - Graphic Menu , Rlx sep '25 ;;; Known limitations : keep app names short , use fixed width & height not really useful, probably gonna remove that ;;; option was intended to be able to have like a 4x4 in center of screen and not fill entire screen... maybe later.. ;;; last update : 2025-09-04 - cleaned up & connected dialog with subroutines ;;; : 2025-09-05 - did some further t&c (tweaking & cleaning) ;;; : 2025-09-06 - time for fieldtesting ;;; : 2025-09-07 - fixed a couple of 1st use issues ;;; : 2025-09-10 - included rlx_sf (defun c:GrMS ( / ;;; globals regkey regvar reg-var-list old-err screen-width screen-height GrM-NoF-Columns GrM-NoF-Rows start-toolbar cell-height cell-width x y cell-number app-list corner start-viewsize app default-button-width default-button-height ;;; test variables so I can run program without dialog tst-NoF-Rows tst-NoF-Columns tst-cell-height tst-cell-width ;;; dimscreen : view x-/y-/x+/y+/height/width/center vx- vy- vx+ vy+ vh vw vc ;;; toolbar corner points tb-x- tb-x+ tb-y- tb-y+ tb-ll tb-ul tb-lr tb-ur tb-dX tb-dY ;;; setup dialog variables setup-dialog-fn setup-dialog-fp setup-dialog-dcl setup-dialog-tl setup-dialog-rd ;;; registry GrM-NoF-Rows ;;; Number of rows in menu , left-right (vertical) Justification GrM-NoF-Columns ;;; Number of columns in menu , left-right (vertical) Justification GrM-Button-Background-Fill ;;; 100(%) means 1 vector line per unit GrM-Button-Width-Height-Ratio ;;; width-ratio 2 means cell width is 2 x cell height GrM-Max-Button-Width-Height-Ratio ;;; set on 3 (width is max 3 times button height) GrM-Max-Button-Background-Fill ;;; 0-100 (%) in steps of 10 GrM-Use-Fixed-Cell-Height ;;; boole , "0" = nope , "1" = jip GrM-Cell-Height ;;; 10 means screen width / 10 GrM-Use-Fixed-Cell-Width ;;; boole , "0" = nope , "1" = jip GrM-Cell-Width ;;; 10 means screen height / 10 GrM-Frame-Color ;;; default is "7" (white) GrM-Text-Color ;;; default is "7" (white) GrM-Background-Color ;;; colors like "8" (gray) , "143" (dirty blue) ;;; options GrM-Max-Columns GrM-Max-Rows ;;; Limmits on number of columns & row GrM-Follow-Justification GrM-Sort-On-Load ;;; Swap #rows - #cols when switching Left/Right - Top/Center/Bottom GrM-Text-Size-Factor ;;; usually 9 or 10 GrM-Toolbar-Justification ;;; left/right/top/bottom/center GrM-App-List-File GrM-Debug-Mode ;;; if "1" function inspect displays variables & values ) ;;; initialyze environment (set_reg_var_list) (princ "\nstart GrM ... ") (GrM_Init) (princ "start setup dialog\n") ;;; (chk_reg_vars) ;;; debug on;y (GrM_Setup_Dialog_Start) (GrM_Exit) (princ) ) (defun c:GrM ( / regkey regvar reg-var-list old-err screen-width screen-height GrM-NoF-Columns GrM-NoF-Rows cell-height cell-width x y cell-number app-list corner vx- vy- vx+ vy+ vh vw vc tb-x- tb-x+ tb-y- tb-y+ tb-ll tb-ul tb-lr tb-ur tb-dX tb-dY setup-dialog-fn setup-dialog-fp setup-dialog-dcl setup-dialog-tl setup-dialog-rd app default-button-width default-button-height GrM-NoF-Rows GrM-NoF-Columns GrM-Button-Background-Fill GrM-Button-Width-Height-Ratio GrM-Max-Button-Width-Height-Ratio GrM-Max-Button-Background-Fill GrM-Use-Fixed-Cell-Height GrM-Cell-Height GrM-Use-Fixed-Cell-Width GrM-Cell-Width GrM-Frame-Color GrM-Text-Color GrM-Background-Color GrM-Max-Columns GrM-Max-Rows GrM-Follow-Justification GrM-Sort-On-Load GrM-Text-Size-Factor GrM-Toolbar-Justification GrM-App-List-File GrM-Debug-Mode) ;;; initialyze environment (set_reg_var_list) (princ "\nstart GrM ... ") (GrM_Init) (princ "start toolbar\n") ;;; (chk_reg_vars) ;;; debug only (GrM_Draw_Toolbar) (if (eq GrM-Debug-Mode "1") (inspect (list 'vh 'vw 'GrM-Toolbar-Justification 'GrM-NoF-Columns 'GrM-NoF-Rows 'GrM-Use-Fixed-Cell-Height 'GrM-Cell-Height 'cell-Height 'GrM-Use-Fixed-Cell-Width 'GrM-Cell-Width 'cell-width 'GrM-Frame-Color 'GrM-Text-Color 'GrM-Background-Color ) ) ) ;;; get user input (GrM_Start_GrRead) (GrM_Exit) ;;; launch app (if app (GrM_Start_App app)) ) (defun set_reg_var_list () (setq reg-var-list (list 'GrM-NoF-Rows 'GrM-NoF-Columns 'GrM-Button-Background-Fill 'GrM-Button-Width-Height-Ratio 'GrM-Max-Button-Width-Height-Ratio 'GrM-Max-Button-Background-Fill 'GrM-Use-Fixed-Cell-Height 'GrM-Cell-Height 'GrM-Use-Fixed-Cell-Width 'GrM-Cell-Width 'GrM-Frame-Color 'GrM-Text-Color 'GrM-Background-Color 'GrM-Max-Columns 'GrM-Max-Rows 'GrM-Follow-Justification 'GrM-Sort-On-Load 'GrM-Text-Size-Factor 'GrM-Toolbar-Justification 'GrM-App-List-File 'GrM-Debug-Mode ) ) ) (defun GrM_Init () ;;; error handler (setq old-err *error* *error* GrM_Err) ;;; setup default data list (unless it exists) (create_default_data_file "c:\\temp\\GrM-Rlx.dat") ;;; init registry variables (InitDefaultRegistrySettings)(ReadSettingsFromRegistry) ;;; record viewsize at session begin (setq start-viewsize (getvar "viewsize")) ;;; get app-list if any (GrM_Preload_App_List) ;;; fixed button height / width is viewsize / factor (default = 12) (setq default-button-height (/ (getvar "VIEWSIZE") 10) default-button-width (* default-button-height 2.0)) ) (defun GrM_Err ($s) (princ (strcat "\n\n\n" $s))(GrM_Exit)(setq *error* old-err)(gc)(princ)) (defun GrM_Exit () ;;; dialog (if (not (null setup-dialog-dcl))(unload_dialog setup-dialog-dcl)) (if (not (null setup-dialog-fp))(close setup-dialog-fp)) (if (and (not (null setup-dialog-fn))(findfile setup-dialog-fn))(vl-file-delete setup-dialog-fn)) ;;; flush cache (redraw)(gc)(terpri)(princ "\r\n")(princ) ) ;;; --- Registry Settings ------------------------------- Begin Registry Settings ------------------------------- Registry Settings --- ;;; (defun InitDefaultRegistrySettings () (record "InitDefaultRegistrySettings") (setq regkey "HKEY_CURRENT_USER\\SOFTWARE\\GrM\\") ;;; regkeys must be strings ;;; ("variable name" "default value") (setq regvar '( ("GrM-NoF-Rows" "10") ;;; Number of rows in menu , left-right (vertical) Justification ("GrM-NoF-Columns" "1") ;;; Number of columns in menu , left-right (vertical) Justification ("GrM-Button-Background-Fill" "100") ;;; 100(%) means 1 vector line per unit ("GrM-Max-Button-Background-Fill" "100") ;;; value between 10-100 (%) in steps of 10 ("GrM-Button-Width-Height-Ratio" "2") ;;; width-ratio 2 means cell width is 2 x cell height ("GrM-Max-Button-Width-Height-Ratio" "3") ;;; limit on how many times the height the width of the button can be. ("GrM-Use-Fixed-Cell-Height" "0") ;;; boole , "0" = nope , "1" = jip ("GrM-Cell-Height" "") ;;; 10 means screen width / 10 ("GrM-Use-Fixed-Cell-Width" "0") ;;; boole , "0" = nope , "1" = jip ("GrM-Cell-Width" "") ;;; 10 means screen height / 10 ("GrM-Frame-Color" "7") ;;; default is "7" (white) ("GrM-Text-Color" "7") ;;; default is "7" (white) ("GrM-Background-Color" "8") ;;; colors like "8" (gray) , "143" (dirty blue) ("GrM-Max-Columns" "10") ;;; Limmits on number of columns ("GrM-Max-Rows" "10") ;;; Limmits on number of rows ("GrM-Follow-Justification" "1") ;;; Swap #rows - #cols when swapping Left/Right - Top/Center/Bottom ("GrM-Sort-On-Load" "1") ;;; Sort app-list upon load ("GrM-Text-Size-Factor" "9") ("GrM-Toolbar-Justification" "left") ;;; left/right/top/bottom/center ("GrM-App-List-File" "c:\\temp\\GrM-Rlx.dat") ("GrM-Debug-Mode" "0") ;;; hidden image button &d toggles dubug ) ) (mapcar '(lambda (x)(set (read (car x)) (cadr x))) regVar) ) (defun ReadSettingsFromRegistry () (record "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 () (record "WriteSettingsToRegistry") (mapcar '(lambda (x) (vl-registry-write regkey (car x) (eval (read (car x))))) regvar)) ;;; (setq a 1 b t c "") (vl-every 'boundp (list 'a 'b 'c)) -> T ;;; (setq a 1 b nil c "") (vl-every 'boundp (list 'a 'b 'c)) -> nil (defun chk_reg_vars () (if (not (vl-every 'boundp reg-var-list)) (progn (princ "\n * reg var err - attempting to reload *") (gc) (ReadSettingsFromRegistry))) (if (not (vl-every 'boundp l)) (progn (alert " * reg var err - please reload GrM *")(exit))) ) ;;; --- Registry Settings -------------------------------- End Registry Settings -------------------------------- Registry Settings --- ;;; ;;; --- dialog section ----------------------------------- begin dialog section ------------------------------------ dialog section --- ;;; ;;; --- 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_Setup_Dialog_Data (%tl) (mapcar '(lambda (x) (eval (car x))) %tl)) (defun Reset_Setup_Dialog_Data (%tl %rd) (mapcar '(lambda (x y) (set (car x) y)) %tl %rd)) (defun Set_Setup_Dialog_Tiles (%tl) (mapcar '(lambda (x / v) (if (eq 'str (type (setq v (eval (car x))))) (set_tile (cadr x) v))) %tl)) (defun Setup_Dialog_Cancel () (Reset_Setup_Dialog_Data setup-dialog-tl setup-dialog-rd) (WriteSettingsToRegistry)) ;;; --- dcl plus-minus block -------------------------------------------------- ;;; _____ ;;; No. Dragons | 1| [ + ] [ - ] ;;; ----- ;;; k = key (will be prexid with eb_ & bt_ / app-list = label / w = edit box width ;;; (dcl_plus_min "rlx" "No. Dragons" "3") ;;; --------------------------------------------------------------------------- (defun dcl_plus_min (k app-list w) (strcat ":row {children_fixed_width=true;" ":text {fixed_width=true;width=10;label=\"" app-list "\";}" ":edit_box {key=\"eb_" k "\";edit_width=" w ";}" ":button {key=\"bt_" k "_plus\";label=\"+\";}" ":button {key=\"bt_" k "_min\";label=\"-\";}spacer;}" ) ) (defun dcl_button_image1 (k app-list) (strcat ":button {fixed_width=true;width=18;key=\"bt_" k "\";label=\"" app-list "\";}" ":image {fixed_width=true;width=4;color=-2;key=\"im_" k "\";}")) (defun GrM_Setup_Dialog_Create ( / f ) (record "GrM_Setup_Dialog_Create") (if (and (setq setup-dialog-fn (vl-filename-mktemp "GrM.dcl")) (setq setup-dialog-fp (open setup-dialog-fn "w"))) (mapcar '(lambda (x)(write-line x setup-dialog-fp)) (list (strcat "GrM_Setup : dialog {label=\"GrM - Setup screen (Rlx " (now) ")\";") ":text_part {key=\"tp_debug_mode\";}" ":boxed_column {label=\"Dimensions\";" " :row {" " :column {" (dcl_plus_min "nof_rows" "Rows" "3") "spacer;"(dcl_plus_min "fill" "Fill (%)" "3") "}" " :column {" (dcl_plus_min "nof_columns" "Columns" "3") (dcl_plus_min "button_width_height_ratio" "Ratio W/H " "3") "}" " }" " :row {alignment=centered;" " :column {width=10;}" " :toggle {label=\"Use fixed cell width\";key=\"tg_use_fixed_width\";}" " :edit_box {edit_width=3;key=\"eb_fixed_width\";}" " :column {width=12;}" " :toggle {label=\"Use fixed cell height\";key=\"tg_use_fixed_height\";}" " :edit_box {edit_width=3;key=\"eb_fixed_height\";}" " :column {width=2;}" " }" "}" ":boxed_row {label=\"Colors\";" (dcl_button_image1 "frame_color" "Frame") (dcl_button_image1 "text_color" "Text") (dcl_button_image1 "background_color" "Background") "}" ":boxed_radio_row {label=\"Justification\";" " :radio_button {key=\"rb_left\";label=\"Left\";}" " :radio_button {key=\"rb_top\";label=\"Top\";}" " :radio_button {key=\"rb_center\";label=\"Center\";}" " :radio_button {key=\"rb_bottom\";label=\"Bottom\";}" " :radio_button {key=\"rb_right\";label=\"Right\";}" "}" "spacer;" ":boxed_column {" " :row {:edit_box {edit_width=3;label=\"Max Col\";key=\"eb_max_columns\";}" " :edit_box {edit_width=3;label=\"Max Row\";key=\"eb_max_rows\";}" " :edit_box {edit_width=3;label=\"Max Ratio\";key=\"eb_max_ratio\";}" " :edit_box {edit_width=3;label=\"Max Fill\";key=\"eb_max_fill\";}" " :edit_box {edit_width=3;label=\"Text size\";key=\"eb_text_size_factor\";}" " }" " spacer;spacer;" " :row {:toggle {label=\"Sort app-list on load\";key=\"tg_sort_on_load\";}" " :toggle {label=\"Follow Justification\";key=\"tg_follow_Justification\";}}" "}" "spacer;spacer;" ":column {:row {fixed_width=true;alignment=centered;" " :button{key=\"bt_app_list\";label=\"App list\";}" " :button{key=\"bt_preview\";label=\"Preview\";}" " :image_button {color=dialog_background;width=0.1;height=0.1;fixed_height=true;key=\"ib_debug_mode\";label=\"&d\";}" " ok_button;cancel_button;}}" "spacer;spacer;" "}" ) ) ) (if setup-dialog-fp (close setup-dialog-fp))(gc) ;(if (setq f (findfile setup-dialog-fn)) (startapp "notepad" f)(alert (strcat "huh? " (vl-princ-to-string f)))) ) (defun GrM_Setup_Dialog_Start ( / drv) (GrM_Setup_Dialog_Create) (if (and (setq setup-dialog-dcl (load_dialog setup-dialog-fn)) (new_dialog "GrM_Setup" setup-dialog-dcl)) (progn (GrM_Setup_Dialog_Update) (GrM_Setup_Dialog_Action) (setq drv (start_dialog)) (if setup-dialog-fn (vl-file-delete setup-dialog-fn)) (cond ((= drv 0)(Setup_Dialog_Cancel)) ((= drv 1)(WriteSettingsToRegistry)(GrM_Draw_Toolbar)) ((= drv 2)(WriteSettingsToRegistry)(Preview_Toolbar)) ) ) ) ) (defun Preview_Toolbar () (GrM_Draw_Toolbar) (princ "\rPress any key to return to dialog") (vl-catch-all-apply 'grread (list nil 8 0)) (redraw) (GrM_Setup_Dialog_Start) ) (defun cycle_Justification ( / co ol i) (setq co GrM-Toolbar-Justification ol '("left" "right" "top" "center" "bottom")) (if (setq i (vl-position co ol)) (progn (if (> i 3) (setq GrM-Toolbar-Justification (nth 0 ol)) (setq GrM-Toolbar-Justification (nth (1+ i) ol)) ) (GrM_Swappie)(WriteSettingsToRegistry)(GrM_Draw_Toolbar) ) ) ) (defun cycle_color ( / c cl i) ;;; grey1 (8), blue (144), green (72), red (12), pink (244), brown (24) (setq c GrM-Background-Color cl '("8" "144" "72" "12" "214" "24")) (if (setq i (vl-position c cl)) (progn (if (> i 4) (setq GrM-Background-Color (nth 0 cl)) (setq GrM-Background-Color (nth (1+ i) cl)) ) ) ;;; user can have selected color not in color list so start with list color numero uno (setq GrM-Background-Color (nth 0 cl)) ) (WriteSettingsToRegistry)(GrM_Draw_Toolbar) ) (defun GrM_Setup_Dialog_Update () (setq setup-dialog-tl '( (GrM-NoF-Rows "eb_nof_rows") (GrM-NoF-Columns "eb_nof_columns") (GrM-Button-Background-Fill "eb_fill") (GrM-Button-Width-Height-Ratio "eb_button_width_height_ratio") (GrM-Use-Fixed-Cell-Width "tg_use_fixed_width") (GrM-Use-Fixed-Cell-Height "tg_use_fixed_height") (GrM-Cell-Width "eb_fixed_width") (GrM-Cell-Height "eb_fixed_height") ;;; options (GrM-Max-Columns "eb_max_columns") (GrM-Max-Rows "eb_max_rows") (GrM-Max-Button-Width-Height-Ratio "eb_max_ratio") (GrM-Max-Button-Background-Fill "eb_max_fill") (GrM-Text-Size-Factor "eb_text_size_factor") (GrM-Follow-Justification "tg_follow_Justification") (GrM-Sort-On-Load "tg_sort_on_load") ;;; GrM-Max-Columns GrM-Max-Rows GrM-Follow-Justification GrM-Sort-On-Load GrM-Text-Size-Factor ) ) ;;; rd = reset data (val1 val2 ...) , in case of a cancel store original values before start of dialog (if (null setup-dialog-rd) (setq setup-dialog-rd (Save_Setup_Dialog_Data setup-dialog-tl))) ;;; set edit boxes and toggle values (Set_Setup_Dialog_Tiles setup-dialog-tl) ;;; update color images (Frame , Text & Background (GrM_Update_Color_Images) ;;; update radiobuttons (Justification top/left/bottom/right (GrM_Update_Radio_Buttons) ;;; Check & set debug mode (set_tile "tp_debug_mode" (if (and GrM-Debug-Mode (eq GrM-Debug-Mode "1")) " * debug mode *" "")) ) (defun GrM_Setup_Dialog_Action () (mapcar '(lambda (x)(action_tile (car x) (cadr x))) '(("cancel" "(done_dialog 0)") ("accept" "(done_dialog 1)") ("bt_preview" "(done_dialog 2)") ("ib_debug_mode" "(Toggle_Debug_Mode)") ("eb_nof_rows" "(setq GrM-NoF-Rows $value)") ;;; GrM_IncTile - just for testing ("bt_nof_rows_plus" "(GrM_IncTile $key 1)") ("bt_nof_rows_min" "(GrM_IncTile $key -1)") ("eb_nof_columns" "(setq GrM-NoF-Columns $value)") ("bt_nof_columns_plus" "(GrM_IncTile $key 1)") ("bt_nof_columns_min" "(GrM_IncTile $key -1)") ("eb_fill" "(setq GrM-Button-Background-Fill $value)") ("bt_fill_plus" "(GrM_IncTile $key 1)") ("bt_fill_min" "(GrM_IncTile $key -1)") ("eb_button_width_height_ratio" "(setq GrM-Button-Width-Height-Ratio $value)") ("bt_button_width_height_ratio_plus" "(GrM_IncTile $key 1)") ("bt_button_width_height_ratio_min" "(GrM_IncTile $key -1)") ;;; fixed width / height ("tg_use_fixed_width" "(setq GrM-Use-Fixed-Cell-Width $value)") ("tg_use_fixed_height" "(setq GrM-Use-Fixed-Cell-Height $value)") ("eb_fixed_width" "(setq GrM-Cell-Width $value)") ("eb_fixed_height" "(setq GrM-Cell-Height $value)") ;;; color handling ("bt_frame_color" "(get_frame_color)") ("bt_text_color" "(get_text_color)") ("bt_background_color" "(get_background_color)") ;;; options ("eb_max_columns" "(setq GrM-Max-Columns $value)") ("eb_max_rows" "(setq GrM-Max-Rows $value)") ("eb_text_size_factor" "(setq GrM-Text-Size-Factor $value)") ("tg_follow_Justification" "(setq GrM-Follow-Justification $value)") ("tg_sort_on_load" "(setq GrM-Sort-On-Load $value)") ;;; toolbar Justification / justification ("rb_left" "(GrM_Set_Justification $key)")("rb_right" "(GrM_Set_Justification $key)") ("rb_top" "(GrM_Set_Justification $key)")("rb_center" "(GrM_Set_Justification $key)") ("rb_bottom" "(GrM_Set_Justification $key)") ;;; ("bt_app_list" "(done_dialog 3)") (GrM_App_List_Dialog) ("bt_app_list" "(GrM_App_List_Dialog)") ) ) ) ;;; low tec but functional (defun Toggle_Debug_Mode () (cond ((eq GrM-Debug-Mode "1") (setq GrM-Debug-Mode "0")) ((eq GrM-Debug-Mode "0") (setq GrM-Debug-Mode "1")) (t (setq GrM-Debug-Mode "0"))) (set_tile "tp_debug_mode" (if (and GrM-Debug-Mode (eq GrM-Debug-Mode "1")) " * debug mode *" "")) ) (defun GrM_Update_Color_Images () (mapcar '(lambda (i c)(GrM_SetColorImage i c)) (list "im_frame_color" "im_text_color" "im_background_color") (list GrM-Frame-Color GrM-Text-Color GrM-Background-Color))) (defun GrM_Update_Radio_Buttons () (cond ((eq GrM-Toolbar-Justification "left")(set_tile "rb_left" "1")) ((eq GrM-Toolbar-Justification "right")(set_tile "rb_right" "1")) ((eq GrM-Toolbar-Justification "top")(set_tile "rb_top" "1")) ((eq GrM-Toolbar-Justification "bottom")(set_tile "rb_bottom" "1")) ((eq GrM-Toolbar-Justification "center")(set_tile "rb_center" "1")) ) ) ;;; when Justification changes from horizontal to vertical , swap nof columns & nof rows (defun GrM_Swappie ( / i1 i2) (setq i1 (atoi GrM-NoF-Columns) i2 (atoi GrM-NoF-Rows)) (cond ;;; horizontal ((member GrM-Toolbar-Justification '("top" "center" "bottom")) (setq GrM-NoF-Columns (itoa (max i1 i2)) GrM-NoF-Rows (itoa (min i1 i2)))) ;;; vertical ((member GrM-Toolbar-Justification '("left" "right" )) (setq GrM-NoF-Columns (itoa (min i1 i2)) GrM-NoF-Rows (itoa (max i1 i2)))) ) ) ;;; gonna assume that when Justification is left or right (vertical) , the number for rows is larger ;;; than the number for columns , this is handeld by setting GrM-Follow-Justification in dialog (defun GrM_Set_Justification (k) (setq GrM-Toolbar-Justification (substr k 4)) (if (eq GrM-Follow-Justification "1") (progn (GrM_Swappie)(set_tile "eb_nof_columns" GrM-NoF-Columns)(set_tile "eb_nof_rows" GrM-NoF-Rows)) ) ) ;;; for now fixed max number of rows / columns to 10 (i is not used anymore , uses tile name instead (defun GrM_IncTile ( tl i / v cmax rmax ratmax fmax) (if (isnum GrM-Max-Columns)(setq cmax (atoi GrM-Max-Columns))(setq cmax 12)) (if (isnum GrM-Max-Rows)(setq rmax (atoi GrM-Max-Rows))(setq rmax 12)) (if (isnum GrM-Max-Button-Width-Height-Ratio)(setq ratmax (atoi GrM-Max-Button-Width-Height-Ratio))(setq ratmax 3)) (if (isnum GrM-Max-Button-Background-Fill)(setq fmax (atoi GrM-Max-Button-Background-Fill))(setq fmax 100)) (cond ;;; columns ((eq tl "bt_nof_columns_plus") (setq GrM-NoF-Columns (itoa (1+ (atoi GrM-NoF-Columns)))) (if (> (atoi GrM-NoF-Columns) cmax) (setq GrM-NoF-Columns (itoa cmax))) (set_tile "eb_nof_columns" GrM-NoF-Columns)) ((eq tl "bt_nof_columns_min") (setq GrM-NoF-Columns (itoa (1- (atoi GrM-NoF-Columns)))) (if (< (atoi GrM-NoF-Columns) 1) (setq GrM-NoF-Columns "1")) (set_tile "eb_nof_columns" GrM-NoF-Columns)) ;;; rows ((eq tl "bt_nof_rows_plus") (setq GrM-NoF-Rows (itoa (1+ (atoi GrM-NoF-Rows)))) (if (> (atoi GrM-NoF-Rows) rmax) (setq GrM-NoF-Rows (itoa rmax))) (set_tile "eb_nof_rows" GrM-NoF-Rows)) ((eq tl "bt_nof_rows_min") (setq GrM-NoF-Rows (itoa (1- (atoi GrM-NoF-Rows)))) (if (< (atoi GrM-NoF-Rows) 1) (setq GrM-NoF-Rows "1")) (set_tile "eb_nof_rows" GrM-NoF-Rows)) ;;; width / height ratio ((eq tl "bt_button_width_height_ratio_plus") (setq GrM-Button-Width-Height-Ratio (itoa (1+ (atoi GrM-Button-Width-Height-Ratio)))) (if (> (atoi GrM-Button-Width-Height-Ratio) ratmax) (setq GrM-Button-Width-Height-Ratio (itoa ratmax))) (set_tile "eb_button_width_height_ratio" GrM-Button-Width-Height-Ratio)) ((eq tl "bt_button_width_height_ratio_min") (setq GrM-Button-Width-Height-Ratio (itoa (1- (atoi GrM-Button-Width-Height-Ratio)))) (if (< (atoi GrM-Button-Width-Height-Ratio) 1) (setq GrM-Button-Width-Height-Ratio "1")) (set_tile "eb_button_width_height_ratio" GrM-Button-Width-Height-Ratio)) ;;; button background fill ((eq tl "bt_fill_plus") (setq GrM-Button-Background-Fill (itoa (+ (atoi GrM-Button-Background-Fill) 10))) (if (> (atoi GrM-Button-Background-Fill) fmax) (setq GrM-Button-Background-Fill (itoa fmax))) (set_tile "eb_fill" GrM-Button-Background-Fill)) ((eq tl "bt_fill_min") (setq GrM-Button-Background-Fill (itoa (- (atoi GrM-Button-Background-Fill) 10))) (if (< (atoi GrM-Button-Background-Fill) 10) (setq GrM-Button-Background-Fill "10")) (set_tile "eb_fill" GrM-Button-Background-Fill)) ;;; overkill...really (t (alert (strcat "\nUnknown IncTile : " (vl-princ-to-string tl) " / " (vl-princ-to-string i)))) ) ) ;;; --- color handling -------------------------------------- color handling --------------------------------------- color handling --- ;;; (defun getcolor (d) (if (or (void d) (not (isnum d)))(setq d 7)) (acad_colordlg d nil)) ;;; check color , byblock/bylayer or nil are converted to color 7 (white) (defun checkcolor (c) (if (string-p c)(setq c (strcase c t))) (cond ((member c '(0 256 "0" "256" "byblock" "bylayer")) 7) ((numberp c) c) ((string-p c)(atoi c)) (t 7))) (defun GrM_SetColorImage (tilename color / col x y ) (if (isnum color) (cond ((= (type color) 'STR) (setq col (atoi color)))((= (type color) 'INT)(setq col color))(t (setq col 7)))) (if (and (string-p color) (member (strcase color T) '("bylayer" "byblock"))) (setq col 7)) (if col (progn (setq x (dimx_tile tilename) y (dimy_tile tilename)) (start_image tilename) (fill_image 0 0 x y col) (end_image))) ) (defun get_frame_color ( / c d ) (if (setq c (acad_colordlg (atoi GrM-Frame-Color) nil)) (progn (GrM_SetColorImage "im_frame_color" c)(setq GrM-Frame-Color (itoa c))))) (defun get_text_color ( / c d ) (if (setq c (acad_colordlg (atoi GrM-text-Color) nil)) (progn (GrM_SetColorImage "im_text_color" c)(setq GrM-text-Color (itoa c))))) (defun get_background_color ( / c d ) (if (setq c (acad_colordlg (atoi GrM-background-Color) nil)) (progn (GrM_SetColorImage "im_background_color" c)(setq GrM-background-Color (itoa c))))) ;;; --- dialog section ------------------------------------ end dialog section ------------------------------------- dialog section --- ;;; ;;; (re) calculate display parameters (dim_screen) ;;; screensize = (1840.0 685.0) (PC dependent / zoom independent) ;;; viewsize = height of current screen , varies with zoom ;;; viewctr = screen center point , varies with zoom ;;; recalculate after each zoom : dx dy / vx- vy- vx+ vy+ / vc vs ss dx dy vx- vy- vx+ vy+ vh vw) (defun dim_screen ( / dx dy) (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE")) ;;; view (half) width & view (half) height (assist for cornerpoints calculation) (setq dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5)) ;;; view corner points (setq vx- (- (car vc) dx) vy- (- (cadr vc) dy) vx+ (+ (car vc) dx) vy+ (+ (cadr vc) dy)) ;;; view height en view width (setq vh (- vy+ vy-) vw (- vx+ vx-)) ;;; inspect / debug ;(inspect (list 'vx- 'vy- 'vx+ 'vy+ 'vh 'vw 'vc)) ) ;;; cell width / height depends on viewsize / #rows / #colomns / Justification ;;; if Justification = horizontal then justification can be top / center / bottom ;;; if Justification = vertical then justification can be left / right ;;; - calculate cell width / cell height ;;; if Justification = horizontal : cell width = screen width / #cols , cell height = cell width / 2 ;;; if Justification = vertical ; cell height = screen height / #rows , cell width = cell height * 2 ;;; - calculate corner points , then start from center point ;;; replaces dim_cell with GrM_Draw_Toolbar which uses data from dialog / registry variables (defun GrM_Draw_Toolbar ( / tb-hw tb-hh) ;;; have no idea why sometimes GrM_Init is skipped , dirty fix (chk_reg_vars) ;;; get view data (dim_screen) ;;; first thing I need is cell height & cell width (if (member GrM-Toolbar-Justification '("top" "center" "bottom")) ;;; horizontal (progn (cond ;;; if use fixed cell width = true ;;; (X-to-N = anything to number , allow zero = 0 , fix numer = 0) ((= GrM-Use-Fixed-Cell-Width "1") (if (not (void GrM-Cell-Width)) (setq cell-width (X-to-N GrM-Cell-Width 0 0))(setq cell-width default-button-width))) ;;; divide screen-width by number of columns ((and (= GrM-Use-Fixed-Cell-Width "0") (setq i (X-to-N GrM-NoF-Columns 0 0))) (setq cell-width (/ vw i))) (t (setq cell-width (/ vw 10.0))) ) (cond ((eq GrM-Auto-Cell-Size-Ratio "1") (setq cell-Height (* cell-width 0.5))) ;;; if use fixed cell height = true ((= GrM-Use-Fixed-Cell-Height "1") (if (not (void GrM-Cell-Height)) (setq cell-height (X-to-N GrM-Cell-Height 0 0))(setq cell-height default-button-height))) (t (setq cell-height (* cell-width 0.5))) ) (setq tb-height (* cell-height (atoi GrM-NoF-Rows))) (cond ((eq GrM-Toolbar-Justification "top") (setq tb-x- vx- tb-y- (- vy+ tb-height) tb-x+ vx+ tb-y+ vy+)) ;;; tb-hw = toolbar half width , tb-hh = toolbar half height ((eq GrM-Toolbar-Justification "center") (setq tb-hw (* (atoi GrM-NoF-Columns) cell-width 0.5) tb-hh (* (atoi GrM-NoF-Rows) cell-height 0.5)) (setq tb-x- (- (car vc) tb-hw) tb-x+ (+ (car vc) tb-hw)) (setq tb-y- (- (cadr vc) tb-hh) tb-y+ (+ (cadr vc) tb-hh)) ) ((eq GrM-Toolbar-Justification "bottom") (setq tb-x- vx- tb-y- vy- tb-x+ vx+ tb-y+ (+ tb-y- tb-height))) ) ) ;;; "vertical" (progn ;;; calculate cell-height first (cond ;;;height is width / 2 ((and (eq GrM-Auto-Cell-Size-Ratio "1") (setq i (X-to-N GrM-NoF-Rows 0 0))) (setq cell-height (/ vh i))) ;;; if use fixed cell height = true (1 "1" T) check height (zero not allowed, dont fix result ((and (= GrM-Use-Fixed-Cell-Height "1") (setq i (X-to-N GrM-Cell-Height 0 0))) (setq cell-Height i)) ;;; divide screen-height by number of rows (zero not allowed , intergers only (fix result) ((and (= GrM-Use-Fixed-Cell-Height "0") (setq i (X-to-N GrM-NoF-Rows 0 0))) (setq cell-height (/ vh i))) ;;; set default for column of 10 rows (t (setq cell-height (/ vh 10.0))) ) ;;; calclate cell-width (cond ((eq GrM-Auto-Cell-Size-Ratio "1") (setq cell-width (* cell-height 2.0))) ;;; if use fixed cell width = true (1 "1" T) check width (zero not allowed, dont fix result ((and (= GrM-Use-Fixed-Cell-Width "1") (setq i (X-to-N GrM-Cell-Width 0 0))) (setq cell-width i)) (t (setq cell-width (* cell-height 2.0))) ) ;;; find toolbar alignment point ;;; for vertical these are left / center / right ;;; calculate width of toolbar for number of columns (setq tb-width (* cell-width (atoi GrM-NoF-Columns))) (cond ((eq GrM-Toolbar-Justification "left") (setq tb-x- vx- tb-y- vy- tb-x+ (+ tb-x- tb-width) tb-y+ vy+)) ((eq GrM-Toolbar-Justification "center") (setq tb-x- (- (car vc) (* tb-width 0.5)) tb-x+ (+ (car vc) (* tb-width 0.5)) tb-y- vy- tb-y+ vy+)) ((eq GrM-Toolbar-Justification "right") (setq tb-x- (- vx+ tb-width) tb-x+ vx+ tb-y- vy- tb-y+ vy+)) ) ) ) (if (eq GrM-Debug-Mode "1") (inspect (list 'vh 'vw 'GrM-Toolbar-Justification 'GrM-NoF-Columns 'GrM-NoF-Rows 'GrM-Use-Fixed-Cell-Height 'GrM-Cell-Height 'cell-Height 'GrM-Use-Fixed-Cell-Width 'GrM-Cell-Width 'cell-width 'GrM-Frame-Color 'GrM-Text-Color 'GrM-Background-Color ) ) ) (setq cell-text-height (/ cell-height 2.0)) ;(setq tst-cell-height cell-height tst-cell-width cell-width) ;;; some more testing (x- y- x+ y+ r c co / xl yl) (Draw_Frame tb-x- tb-y- tb-x+ tb-y+ (atoi GrM-NoF-Rows) (atoi GrM-NoF-Columns) 2) ) ;;; x-=xmin, x+=ymax etc, r=rows, c=columns, co=color ;;; (setq e- (getvar "EXTMIN") e+ (getvar "EXTMAX")) ;;; (Draw_Frame (car e-)(cadr e-)(car e+)(cadr e+) 5 5 1) (defun Draw_Frame (x- y- x+ y+ r c co / xl yl pl text-size bcol fcol tcol justy ) (record "Draw_Frame") (if (and (not (void GrM-background-Color))(isnum GrM-background-Color)) (setq bcol (atoi GrM-background-Color))(setq col 142)) (if (and (not (void GrM-Frame-Color))(isnum GrM-Frame-Color)) (setq fcol (atoi GrM-Frame-Color))(setq fcol 7)) (if (and (not (void GrM-Text-Color))(isnum GrM-Text-Color)) (setq tcol (atoi GrM-Text-Color))(setq tcol 7)) (redraw)(Fill_Toolbar_Background x- y- x+ y+ bcol) ;;; create x & y list for all grid coordinates (setq xl (gnl+ x- (1+ c) (/ (abs (- x+ x-)) c)) yl (gnl- y+ (1+ r) (/ (abs (- y+ y-)) r))) ;;; draw all horizontal lines (foreach y yl (grdraw (list x- y) (list x+ y) fcol)) ;;; draw all vertical lines (foreach x xl (grdraw (list x y+) (list x y-) fcol)) ;;; draw the texts (setq pl (gmpl xl yl)) ;;; cell-text-height is cell-height / 2 (if (and (not (void GrM-Text-Size-Factor))(isnum GrM-Text-Size-Factor)) (setq text-size (/ cell-text-height (atoi GrM-Text-Size-Factor))) (setq text-size (/ cell-text-height 9)) ) ;;; bad idea : grtxt routine has its limitations so I'll adjust text justification along with toolbar Justification ;;; all text insertion points are calculated based on middle algnment so lets keep it that way for now ;(cond ((eq GrM-Toolbar-Justification "left")(setq justy "L"))((eq GrM-Toolbar-Justification "right")(setq justy "R"))(t (setq justy "M"))) (setq justy "M") (mapcar '(lambda (p s) (grtxt (strcase s) p tcol 0 justy text-size)) pl (if (vl-consp app-list) (mapcar 'vl-filename-base app-list) '("Empty"))) (princ) ) ;;; fill toolbar background (defun Fill_Toolbar_Background (x- y- x+ y+ c / y vws bgf-fac delta-y) (setq y y- vws (getvar "viewsize") bgf-fac (/ 0.1 (/ (atof GrM-Button-Background-Fill) 100.0))) (setq delta-y (/ vws 1000.0)) (while (<= y y+)(grdraw (list x- y)(list x+ y) c)(setq y (+ y (* delta-y bgf-fac (/ vws start-viewsize)))))) ;;; (setq cel-id (GrM_GetCellNumber x y)) (defun GrM_GetCellNumber (x y / id ) ;;; cell number from dialog , without accouting for page number ;(setq id (+ (* (atoi GrM-NoF-Columns) (fix (/ y cell-height))) (fix (1+ (/ x cell-width))))) (if (eq tst-Justification "horizontal") (setq id (+ (* (atoi tst-NoF-Columns) (fix (/ y tst-cell-height))) (fix (1+ (/ x tst-cell-width))))) (setq id (+ (* (atoi tst-NoF-Rows) (fix (/ y tst-cell-height))) (fix (1+ (/ x tst-cell-width))))) ) ) ;;; (GrM_GetCell-ID (list 100.0 100.0) (list 130.0 70.0) 3 3 (list 122.0 79.0)) ;;; get cell-id from point selection to use as nth for app-list (defun GrM_GetCell-ID (ul lr c r p / dy dy x y)(setq x (car p) y (cadr p)) (setq dx (/ (abs (- (car lr) (car ul))) c) dy (/ (abs (- (cadr ul) (cadr lr))) r)) (+ (/ (fix (abs (- x (car ul))))(fix dx))(* (1- (- r (/ (fix (abs (- y (cadr lr))))(fix dy)))) c)) ) ;;; (show_grid) (defun show_grid ( / x dx y dy i) (setq x (fix screen-width) y (fix screen-height)) (setq dy (/ y (atoi GrM-NoF-Rows)) dx (/ x (atoi GrM-NoF-Columns))) (setq i 0)(while (< i x)(grdraw (list i 0) (list i y) 3)(setq i (fix (+ i dx)))) (setq i 0)(while (< i y)(grdraw (list 0 i) (list x i) 3)(setq i (fix (+ i dy))))) ;;; (setq corner (GrM_GetCellCorner 5)) (defun GrM_GetCellCorner ( cell / col row) (if (= (rem cell (atoi GrM-NoF-Columns)) 0) (setq col (atoi GrM-NoF-Columns) row (1- (/ cell (atoi GrM-NoF-Columns)))) (setq col (rem cell (atoi GrM-NoF-Columns)) row (/ cell (atoi GrM-NoF-Columns)))) (list (* cell-width (1- col)) (* cell-height row))) ;;; (Dim_Box (list 400 75) cell-width cell-height) ;;; arg top left point , width , height , return list cornerpoints (defun Dim_Box (p w h) (list p (polar p 0 w) (polar p (atan h w) (sqrt (+ (expt w 2)(expt h 2)))) (polar p (/ pi 2) h))) ;;; --- GrTxt ---------------------------------------------------- GrTxt ---------------------------------------------------- GrTxt --- ;;; ;;; found this old lisp (grtxt.lsp) , don't know author but all credits are for this human from earth ;;; text string / coordinate point / color / angle / justification/ z for text height ;;; *** UPPER CASE ONLY *** (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M") ;;; 2025-07-29 added z for text height as parameter (defun grtxt (ts cp cl a j z / vp ltb i xp c p1 p2 lp ld n al) ;;; vertex points (setq vp '(( 1 ( 0.50 0.25))( 2 ( 0.50 0.55))( 3 ( 0.50 0.85))( 4 ( 0.50 1.00))( 5 ( 0.25 1.00)) ( 6 ( 0.00 1.00))( 7 (-0.25 1.00))( 8 (-0.50 1.00))( 9 (-0.50 0.85))(10 (-0.50 0.55)) (11 (-0.50 0.25))(12 (-0.50 0.10))(13 (-0.25 0.10))(14 ( 0.00 0.10))(15 ( 0.25 0.10)) (16 ( 0.50 0.10))(17 ( 0.50 -0.05))(18 ( 0.50 -0.45))(19 ( 0.50 -0.85))(20 ( 0.50 -1.00)) (21 ( 0.25 -1.00))(22 ( 0.00 -1.00))(23 (-0.25 -1.00))(24 (-0.50 -1.00))(25 (-0.50 -0.85)) (26 (-0.50 -0.40))(27 (-0.50 -0.05))(30 ( 0.35 0.85))(31 (-0.35 0.85))(32 (-0.35 -0.85)) (33 ( 0.35 -0.85))(40 ( 0.25 0.35))(41 (-0.25 0.35))(42 ( 0.25 -0.15))(43 (-0.25 -0.15)) (44 ( 0.00 0.45))(45 ( 0.00 -0.25))(50 ( 0.30 0.20))(51 ( 0.30 0.35))(52 ( 0.20 0.35)) (53 ( 0.20 0.20))(54 ( 0.30 0.10))(55 ( 0.30 -0.10))(56 ( 0.20 -0.10))(57 ( 0.20 0.10)) (60 (-0.30 0.20))(61 (-0.30 0.35))(62 (-0.20 0.35))(63 (-0.20 0.20))(64 (-0.30 0.10)) (65 (-0.30 -0.10))(66 (-0.20 -0.10))(67 (-0.20 0.10)))) ;;; letter table (setq ltb '(("A" 24 9 7 5 3 20 16 12) ("B" 12 15 1 3 5 8 24 21 19 17 15) ("C" 3 5 7 9 25 23 21 19) ("D" 3 5 8 24 21 19 3) ("E" 4 8 12 15 12 24 20) ("F" 4 8 12 15 12 24) ("G" 3 5 7 9 25 23 21 19 16 14) ("H" 20 -4 8 -24 16 12) ("I" 7 5 6 22 23 21) ("J" 4 19 21 23 25) ("K" 8 24 12 13 4 13 20) ("L" 8 24 20) ("M" 24 8 14 4 20) ("N" 24 8 20 4) ("O" 3 5 7 9 25 23 21 19 3) ("P" 12 15 1 3 5 8 24) ("Q" 3 5 7 9 25 23 21 19 3 -19 20 45) ("R" 20 14 12 15 1 3 5 8 24) ("S" 3 5 7 9 11 13 15 17 19 21 23 25) ("T" 4 8 6 22) ("U" 8 25 23 21 19 4 20) ("V" 8 22 4) ("W" 8 23 14 21 4) ("X" 4 -24 8 20) ("Y" 8 14 22 14 4) ("Z" 8 4 24 20) ("0" 3 5 7 9 25 23 21 19 -3 4 24) ("1" 31 7 6 22 21 23) ("2" 9 7 5 3 1 15 13 27 24 20) ("3" 9 7 5 3 1 15 13 15 17 19 21 23 25) ("4" 8 12 16 15 5 21) ("5" 4 8 12 15 17 19 21 23 25) ("6" 3 5 7 9 25 23 21 19 17 15 12) ("7" 8 4 22) ("8" 3 5 7 9 11 13 27 25 23 21 19 17 15 13 15 1 3) ("9" 25 23 21 19 3 5 7 9 11 13 16) ("<" 4 12 20) (">" 8 16 24) ("," 33 21) ("." 19 20 21 33 19) ("\'" 4 30) ("\"" 4 -30 7 31) (";" 50 51 52 53 -50 54 55 56 57 55 45) (":" 50 51 52 53 -50 54 55 56 57 55) ("\\" 8 20) ("/" 4 24) ("?" 11 10 7 5 2 1 45 22) ("|" 6 -44 45 22) ("+" 44 -45 13 15) ("=" 40 -41 43 42) ("-" 13 15) ("_" 20 24) (")" 6 2 18 22) ("(" 6 10 26 22) ("*" 40 -43 41 -42 45 44) ("&" 21 31 7 6 26 25 23 16) ("^" 10 6 2) ("%" 57 54 55 56 -57 63 60 61 62 -63 5 24) ("$" 3 5 7 9 11 13 15 17 19 21 23 25 -26 22 6) ("#" 24 -6 22 -4 1 -11 17 27) ("@" 42 15 40 44 41 13 43 45 42 17 3 5 7 9 25 23 21 19) ("!" 6 -45 22 22) ("~" 9 31 44 40 2) ("`" 8 31) ("[" 6 8 24 22) ("]" 6 4 20 22) ("{" 6 7 41 12 43 23 22) ("}" 6 5 40 16 42 21 22) (""))) ;;; text height - use z as parameter ;;;(setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.1)) ;;;(setq z (/ (getvar "VIEWSIZE") 10)) (cond ;;; left justification ((eq (strcase (substr j 1 1)) "L") (setq xp (list (+ (car cp) z) (cadr cp)) i 1)) ;;; middle justification ((eq (strcase (substr j 1 1)) "M") (setq xp (list (- (car cp) (* z (strlen ts) 0.5)) (cadr cp)) i 1)) ;;; right justification ((eq (strcase (substr j 1 1)) "R") (setq xp (list (- (car cp) (* z (strlen ts) 1.5)) (cadr cp)) i 1)) ) (repeat (strlen ts) ;;; each charachter / line point list / letter point def (setq c (substr ts i 1) lp '() ld (cdr (assoc c ltb))) (while (> (length ld) 1) (setq p1 (cadr (assoc (abs (nth 0 ld)) vp)) p2 (cadr (assoc (abs (nth 1 ld)) vp)) p1 (mapcar '* (list z z) p1) p2 (mapcar '* (list z z) p2) p1 (mapcar '+ xp p1) p2 (mapcar '+ xp p2) lp (append lp (list (if (minusp (nth 0 ld)) 0 cl) p1 p2)) ld (cdr ld)) ) ;;; add rotation angle (setq n 0 al nil) (repeat (/ (length lp) 3) (setq al (cons (nth n lp) al) al (cons (polar cp (+ a (angle cp (nth (+ n 1) lp))) (distance cp (nth (+ n 1) lp))) al) al (cons (polar cp (+ a (angle cp (nth (+ n 2) lp))) (distance cp (nth (+ n 2) lp))) al)) (setq n (+ n 3)) ) (and al (grvecs (reverse al))) (setq xp (list (+ (car xp) (* z 1.5)) (cadr xp)) i (1+ i)) ) (prin1) ) ;;; --- GrTxt ---------------------------------------------------- GrTxt ---------------------------------------------------- GrTxt --- ;;; ;;; --- App list dialog ------------------------------------- App list dialog ------------------------------------- App list dialog --- ;;; ;;; Simple File Dialog ;;; f = dialog file name , p = pointer , d = dialog , app-list = list , i = input , idx = listbox index (defun GrM_App_List_Dialog ( / f p d app-list i idx regkey regvar Filli-Dat-File return-to-setup-dialog) (setq idx 0) ;;; (InitDefaultRegistrySettings)(ReadSettingsFromRegistry) ;;; first use (if (or (null GrM-App-List-File)(not (eq (type GrM-App-List-File) 'STR))) (progn (setq GrM-App-List-File (vl-filename-mktemp "app-list.dat") p (open GrM-App-List-File "w")) (close p)(gc) ) ) ;;; read data file (if (and (findfile GrM-App-List-File)(setq p (open GrM-App-List-File "r"))) (progn (while (setq i (read-line p))(setq app-list (cons i app-list)))(close p))) ;;; check data list (if (vl-consp app-list)(setq app-list (acad_strlsort app-list)) (setq app-list (list "Empty"))) ;;; create dialog (if (and (setq f (vl-filename-mktemp "filli.dcl") p (open f "w"))) (mapcar '(lambda (x)(write-line x p)) (list (strcat "app_list : dialog {label=\"App list dialog (Rlx " (now) ")\";") "spacer;:text_part {key=\"tp\";}spacer;" ":boxed_row {label=\"File list\";:column {:list_box {key=\"lb\";width=64;}}spacer;" ":column {:button {key=\"add\";label=\"Add\";}:button {key=\"del\";label=\"Del\";}" ":button {key=\"up\";label=\"Up\";}:button {key=\"down\";label=\"Down\";}:button {key=\"sort\";label=\"Sort\";}}}" ":text_part {key=\"tp_file_info\";}" "spacer; :column {:row {fixed_width=true;alignment=centered;:button{key=\"load\";label=\"Load\";}" ":button{key=\"save\";label=\"Save\";}:button{key=\"saveas\";label=\"Saveas\";}" ":button{key=\"edit\";label=\"Edit\";} ok_button;cancel_button;}}spacer;spacer;}" ) ) (princ "\nComputer says no : unable to create dialog") ) ;;; clean desk policy (if p (progn (close p)(gc))) ;;; start dialog (if (and (setq d (load_dialog f)) (new_dialog "app_list" d)) (progn ;;; fill list box (setq idx 0)(lb_upd) ;;; activate buttons (action_tile "cancel" "(done_dialog 0)")(action_tile "accept" "(done_dialog 1)") (action_tile "lb" "(setq idx (atoi $value))(lb_upd_info)") (mapcar '(lambda (x)(action_tile x "(action_key $key)")) '("add" "del" "up" "down" "sort" "load" "save" "saveas" "edit")) (setq drv (start_dialog)) (if (and f (setq f (findfile f))) (vl-file-delete f)) (cond ((= drv 0)) ((= drv 1)(WriteSettingsToRegistry)) ) ) ) ) ;;; just to have a little less code in main loop (defun action_key (k) (cond ((= k "add")(_add))((= k "del")(_del))((= k "up")(lb_mod "up"))((= k "down")(lb_mod "down")) ((= k "sort")(lb_sort))((= k "load")(_load))((= k "save")(_save))((= k "saveas")(_saveas)) ((= k "edit")(_edit_dat_file)) ) ) ;;; lb_upd = update list box (init / redraw / refresh) (defun lb_upd () (set_tile "tp" (strcat " Data file : " (vl-princ-to-string GrM-App-List-File))) (start_list "lb")(mapcar 'add_list (mapcar 'vl-filename-base app-list))(end_list) (set_tile "lb" (itoa idx)) (lb_upd_info) ) ;;; update the text part below listbox to show complete path & filename (defun lb_upd_info () (if (vl-consp app-list) (set_tile "tp_file_info" (strcat " File : " (vl-princ-to-string (nth idx app-list)))) (set_tile "tp_file_info" " File : - ") ) ) ;;; lb_sort = sort list box (defun lb_sort () (setq app-list (acad_strlsort app-list)) (start_list "lb")(mapcar 'add_list app-list)(end_list)(set_tile "lb" (itoa idx))) ;;; lb_mod = modify list box ;;; m = mode up or down ("u" or "d") , app-list = app list (global) , xl = temp list (local) ;;; idx = index (global) , i = index (local) , i1 / i2 = scrap lists (local) (defun lb_mod (m / i xl i1 i2) (setq i idx xl (vl-remove-if '(lambda (x)(= x "")) app-list)) (cond ((void i))((or (null xl)(< (length xl) 2)))((and (= i 0) (= m "up")))((and (>= i (1- (length xl)))(= m "down"))) (t (setq i1 (nth i xl)) (if (= m "up") (setq i (1- i) i2 (nth i xl)) (setq i (1+ i) i2 (nth i xl) )) (setq xl (subst "i1" i1 xl) xl (subst "i2" i2 xl) xl (subst i2 "i1" xl) xl (subst i1 "i2" xl) idx i))) (cond ((< idx 0)(setq idx 0)) ((>= idx (length xl))(setq idx (1- (length xl))))) (setq app-list xl) (lb_upd) ) ;;; --- Tiny lisp section --------------------------------- Tiny lisp section ----------------------------------- Tiny lisp section --- ;;; (defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x))))) (defun isnum (n)(if (or (numberp n) (and (= (type n) 'STR) (distof n))) t nil)) (defun string-p (s) (if (= (type s) 'str) t nil)) (defun uc (s) (alert (strcat "Under construction : " s))) (defun now ( / s l ) (setq s (rtos (getvar "CDATE")) l '("Jan""Feb""Mar""Apr""May""Jun""Jul""Aug""Sep""Oct""Nov""Dec")) (strcat (substr s 7 2) "-" (nth (1- (atoi (substr s 5 2))) l) "-'" (substr s 3 2))) ;;; remove from list (defun rfl (e app-list) (apply 'append (subst nil (list e) (mapcar 'list app-list)))) ;;; anything to number : n = number in any format (INT/REAL/STR) , z = allow 0 (zero) , f = fix result ;;; (X-to-N "0.0" 0 0) = nil , (X-to-N "0.0" 1 0) = 0.0 , (X-to-N "0.0" 1 1) = 0 , (X-to-N "rlx" 1 1) = nil (defun X-to-N (n z f / r ) (cond ((eq (type n) 'INT )(setq r n))((eq (type n) 'REAL)(setq r n))((distof n)(setq r (distof n)))(t (setq r nil))) (cond ((not r))((and (zerop r) (member z '(0 "0" nil)))(setq r nil)))(cond ((not r) nil)((member f '(1 "1" T))(fix r))(t (float r)))) ;;; for debugging , sort of trace list (defun record (s)(setq rec-list (cons s rec-list))) ;;; (setq rec-list nil) ;;; (setq a 1 b nil) (inspect (list 'a 'b)) (defun inspect (lst / _f) (defun _f (l) (apply 'strcat (cdr (apply 'append (mapcar (function (lambda (x) (list "\n" x))) l))))) (alert (_f (mapcar '(lambda (x) (strcat (vl-symbol-name x) " = " (vl-princ-to-string (vl-symbol-value x)))) lst)))) ;; tiny lisps ;;; generate number (gnum 1 5) -> '(1 2 3 4 5) (defun gnum (s e / i l) (and (numberp s)(numberp e)(setq i s)(while (<= i e)(setq l (cons i l) i (1+ i)))) (reverse l)) ;;; i = startnumber n = number of numbers , d = difference (gnl- 100 6 12) -> (100 88 76 64 52 40) ;;; generate all x-coordinates between xmin=322.5 & xmax =347.5 , 5 columns ;;; (gnl- xmax col+1 (- xmax xmin)) ;;; (gnl- 347.5 (1+ 5) (/ (- 347.5 322.5) 5)) -> (347.5 342.5 337.5 332.5 327.5 322.5) (defun gnl- (i n d / l)(setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l)) ;;; same but incremental ;;; (gnl- xmin (1+ col) (- xmax xmin)) (gnl- -10 6 (- -10 10)) ;;; (gnl+ 322.5 (1+ 5) (/ (- 347.5 322.5) 5)) -> (322.5 327.5 332.5 337.5 342.5 347.5) (defun gnl+ (i n d / l)(setq l (list i))(repeat (1- n)(setq l (cons (setq i (+ i d)) l)))(reverse l)) ;;; generate midpoint list ;;; (gmpl '(10 20 30 40 ) '(100 90 80)) -> '((15 95) (25 95) (35 95) (15 85) (25 85) (35 85)) (defun gmpl (xl yl / f x y) (defun f (l)(mapcar '(lambda (a b) (+ a (/ (- b a) 2.0))) l (cdr l))) (setq x (f '(10 20 30 40))) ;;; -> '(15.0 25.0 35.0) (setq y (f '(100 90 80))) ;;; -> '(95.0 85.0) (mapcar '(lambda (yy) (mapcar '(lambda (xx)(cons xx yy)) (f '(10 20 30 40)))) (f '(100 90 80))) ;;; -> (((15.0 . 95.0) (25.0 . 95.0) (35.0 . 95.0)) ((15.0 . 85.0) (25.0 . 85.0) (35.0 . 85.0))) ) ;;; (gmpl '(10 20 30 40 ) '(100 90 80)) (defun gmpl (xl yl / f) (defun f (l)(mapcar '(lambda (a b)(+ a (/ (- (float b) (float a)) 2.0))) l (cdr l))) (apply 'append (mapcar '(lambda (y)(mapcar '(lambda (x)(list x y 0.0))(f xl)))(f yl)))) ;;; rlx_sf - sub folders : c:/temp/test -> ("c:" "temp" "test") (defun rlx_sf ( fol / i) (if (setq i (vl-string-search "\\" fol)) (cons (substr fol 1 i) (rlx_sf (substr fol (+ i 1 (strlen "\\"))))) (list fol))) ;;; rlx_mf - make folder (defun rlx_mf ( fol / sf) (defun MF (rt sf) (if sf ((lambda (fol)(vl-mkdir fol)(MF fol (cdr sf)))(strcat rt "\\" (car sf))))) (if (setq sf (rlx_sf (vl-string-translate "/" "\\" fol))) (MF (car sf) (cdr sf))) (vl-file-directory-p fol)) ;;; --- Tiny lisp section --------------------------------- Tiny lisp section ----------------------------------- Tiny lisp section --- ;;; ;;; --- File operations ------------------------------------ File operations -------------------------------------- File operations --- ;;; ;;; load / save (data) file ;;; app-list = global list for list box , app-list is global name for data file (defun _load ( / fn fp i lst def) (if (or (void GrM-App-List-File) (not (setq def (car (fnsplitl GrM-App-List-File)))) (not (vl-file-directory-p def)))(setq def "")) (if (and (setq fn (getfiled "Select a data file" def "dat" 0))(setq fp (open fn "r"))) (while (setq i (read-line fp))(setq lst (cons i lst)))) (if fp (close fp)) (if (vl-consp lst) (progn (if (and (> (length lst) 1)(member "Empty" lst)) (setq lst (vl-remove "Empty" lst))) (setq GrM-App-List-File fn) (if (eq GrM-Sort-On-Load "1") (setq app-list (acad_strlsort lst)) (setq app-list (reverse lst)) ) (lb_upd) (WriteSettingsToRegistry) ) ) ) ;;; (create_default_data_file "c:\\temp\\rlx\\rlx\\xxx.xxx") (defun create_default_data_file ( fn / split) (cond ((or (null fn) (not (eq (type fn) 'STR)) (eq fn "")) (alert (strcat "unable to create file : " (vl-princ-to-string fn)))) ((findfile fn)) (t (setq split (fnsplitl fn)) (if (not (vl-file-directory-p (car split))) (rlx_mf (car split))) (if (setq fp (open fn "w")) (progn (close fp)(gc)) (alert (strcat "unable to create file : " (vl-princ-to-string fn))) ) ) ) ) (defun GrM_Preload_App_List ( / fn fp lst) (if (and (not (void (setq fn GrM-App-List-File)))(findfile fn)(setq fp (open fn "r"))) (while (setq i (read-line fp))(setq lst (cons i lst)))) (if fp (close fp)) ;(if (vl-consp lst)(setq app-list lst)(setq app-list '("Empty"))) (if (vl-consp lst)(setq app-list (reverse lst))(setq app-list '("Empty"))) ) (defun _save ( / fn fp def ) (if (and (not (void (setq fn GrM-App-List-File)))(findfile fn)(vl-consp app-list)(setq fp (open fn "w"))) (progn ;;; remove "Empty" from list if items have been added (if (and (> (length app-list) 1)(member "Empty" app-list)) (setq app-list (vl-remove "Empty" app-list))) (foreach x app-list (write-line x fp)) (close fp) (gc) ) ) ) (defun _saveas ( / fn fp def ) (if (or (void GrM-App-List-File) (not (setq def (car (fnsplitl GrM-App-List-File)))) (not (vl-file-directory-p def)))(setq def "")) (if (and (vl-consp app-list)(setq fn (getfiled "Select a data file" def "dat" 1))(setq fp (open fn "w"))) (progn (foreach x app-list (write-line x fp))(close fp)(gc) (setq GrM-App-List-File fn)(WriteSettingsToRegistry) ) ) ) ;;; add / del to / from list ;;; update : add full path instead of filename only (defun _add ( / f d e) (setq e "lsp") (if (or (void GrM-App-List-File)(not (setq d (car (fnsplitl GrM-App-List-File))))(not (vl-file-directory-p d)))(setq d "")) (if (setq f (getfiled "Select a lisp file" d e 0)) (progn (if (or (not (vl-consp app-list)) (equal app-list (list "Empty"))) (setq app-list (list f)) (setq app-list (append app-list (list f))) ) (lb_upd) ) ) ) (defun _del () (setq app-list (rfl (nth idx app-list) app-list)) (lb_upd)) (defun _edit_dat_file ( / fn) (if (and (not (void (setq fn GrM-App-List-File)))(findfile fn)) (progn (done_dialog) (startapp "notepad" fn)(alert "Press ok when done")(GrM_App_List_Dialog)))) ;;; --- File operations ------------------------------------ File operations -------------------------------------- File operations --- ;;; (defun GrM_Start_GrRead ( / done inp) (setq done nil) (while (not done) (princ "\rSelect button or [B]ackground color,[CcRr] (+/- col/row),[J]ustification,[S]etup,[Z]oom (E/+/-),[Q]uit (Space/Enter/Esc/RM) :") (setq inp (vl-catch-all-apply 'grread (list nil 8 0))) (cond ((vl-catch-all-error-p inp)(setq done T)) ;;; point selection ((= (car inp) 3) (setq pt (cadr inp)) (setq id (GrM_GetCell-ID (list tb-x- tb-y+) (list tb-x+ tb-y-) (atoi GrM-NoF-Columns) (atoi GrM-NoF-Rows) pt)) (setq app (nth id app-list) done T)) ;;; nah, just for fun...j/J key cycles Justification ((or (equal inp '(2 106))(equal inp '(2 74)))(cycle_Justification)) ;;; also lots of fun...B key cycles background color ((or (equal inp '(2 66))(equal inp '(2 98)))(cycle_color)) ;;; s or S (setup) ((or (equal inp '(2 115))(equal inp '(2 83)))(GrM_Setup_Dialog_Start)) ; user pressed E of e ((member inp '((2 69)(2 101))) (command "zoom" "e")(GrM_Draw_Toolbar)) ; user pressed + ((equal inp '(2 43)) (vl-cmdf "zoom" "2x")(GrM_Draw_Toolbar)) ; user pressed - ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x")(GrM_Draw_Toolbar)) ; user pressed z or Z ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" "")(GrM_Draw_Toolbar)) ;;; Enter Space or q/Q key or R-mouse button ((or (equal inp '(2 13)) (equal inp '(2 32)) (equal inp '(2 113)) (equal inp '(2 81)) (equal (car inp) 25)) (setq done T)) ; user pressed D of d - Toggle Debug Mode ((member inp '((2 68)(2 100)))(Toggle_Debug_Mode)) ;;; c (column) smaller (2 99) (GrM_IncTile "bt_nof_columns_min" 0) ((equal inp '(2 99)) (GrM_IncTile "bt_nof_columns_min" 0)(GrM_Draw_Toolbar)) ;;; K (Kolom = column) bigger (2 67) (GrM_IncTile "bt_nof_columns_plus" 0) ((equal inp '(2 67)) (GrM_IncTile "bt_nof_columns_plus" 0)(GrM_Draw_Toolbar)) ;;; r (row) smaller (2 114) (GrM_IncTile "bt_nof_rows_min" 0) ((equal inp '(2 114)) (GrM_IncTile "bt_nof_rows_min" 0)(GrM_Draw_Toolbar)) ;;; R (row) bigger (2 82) (GrM_IncTile "bt_nof_rows_plus" 0) ((equal inp '(2 82)) (GrM_IncTile "bt_nof_rows_plus" 0)(GrM_Draw_Toolbar)) ) ) (redraw) ) ;;; program assumes no self starting routines and start command is "C:" + app name (defun GrM_Start_App (app / fn) (cond ((setq fn (findfile app)) (redraw)(load fn)(eval (read (strcat "(C:" (vl-filename-base app) ")")))) (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye"))) ) (princ) ) (vl-load-com) (princ "\nGrM - Graphic Menu - Rlx - last update 2025/09/10 (added rlx_sf)") (princ) ;;; (c:GrMs) ;;; Setup Dialog ;;; (C:GrM) ;;; Display Toolbar

not sure what you want to accomplish with this? would a simple insert not do the same. You could retrieve all objects after explode : Your code won't work this way but nice try. If you want to copy object between drawings it would work something like this : ;;; copy selectionset to drawing (defun ctd ( ss dwg / ss->ol dbx_ver acApp acDoc dbx object-list object-safe-array) (defun SS->OL (ss / i l) (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun dbx_ver ( / v) (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))) (setq acApp (vlax-get-acad-object) acDoc (vla-get-ActiveDocument acApp)) (setq dbx (vl-catch-all-apply 'vla-getinterfaceobject (list acApp (dbx_ver)))) (vla-open dbx dwg) ; put all objects from SS in a list (foreach object (ss->ol ss) (setq object-list (cons object object-list))) ; put list with objects in a safe array (setq object-safe-array (vlax-make-safearray vlax-vbobject (cons 0 (1- (length object-list))))) (vl-catch-all-apply 'vlax-safearray-fill (list object-safe-array object-list)) ; copy objects to dbx-drawing (vla-CopyObjects acDoc object-safe-array (vla-get-ModelSpace dbx)) (vl-catch-all-apply 'vla-saveas (list dbx dwg)) (vl-catch-all-apply 'vlax-release-object (list dbx)) (setq object-list nil object-safe-array nil) (princ) ) (defun c:t1 ( / ss d) (if (and (setq ss (ssget)) (setq d (getfiled "Copy SS to:" "" "dwg" 0))) (ctd ss d) ) (princ) ) the other way around (very little error trapping , like selected drawing must be closed) : ;;; copy from (dbx) drawing (all objects / all layouts) (defun cfd ( / acApp acDoc dbx dwg object-list object-safe-array) (defun SS->OL (ss / i l) (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l) (defun dbx_ver ( / v) (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v))))) (setq acApp (vlax-get-acad-object) acDoc (vla-get-ActiveDocument acApp)) (setq dbx (vl-catch-all-apply 'vla-getinterfaceobject (list acApp (dbx_ver)))) (setq dwg (getfiled "Copy (all) objects from :" "" "dwg" 0)) (vla-open dbx dwg) (vlax-for block (vla-get-blocks dbx) (vlax-for object block (setq object-list (cons object object-list)) ) ) ; put list with objects in a safe array (setq object-safe-array (vlax-make-safearray vlax-vbobject (cons 0 (1- (length object-list))))) (vl-catch-all-apply 'vlax-safearray-fill (list object-safe-array object-list)) ; copy objects from dbx-drawing to active drawing (vla-CopyObjects dbx object-safe-array (vla-get-ModelSpace acDoc)) (vl-catch-all-apply 'vlax-release-object (list dbx)) (princ) ) Probably master Lee also has some routines on his web site to copy between drawings Latest AutoCad versions have a compare drawing command?

Haven't looked at the code but FYI. Entity names are generated when the drawing is open making them unique and random and only valid for that drawing. You can't save an entity name's and call it later when a drawing is closed or use entget with that entity name from another drawing. -edit So a circle in two drawings with everything the same layer, color, xyz location will have two different entity names. <Entity name: 1A3F5B7C> <Entity name: 2B8E4D9A>

@Steven P I used it mostly for inserting text in blocks that need to be specific fonts, spacing, layers , and color. a side note even tho the blocks are exploded they are in the block library until you purge. keep that in mind when using generic block names. pasting a block from a different drawing will pull from the block library instead if they have the same name not the clipboard. So if block1 is a circle in DrawingA and a square in DrawingB. Selecting the block in drawingA and copy paste into DrawingB when it paste all the blocks will be squares. not the circles you copied.

Good stuff @mhupp! OP, why not just draw the polylines with LISP?

I didn't know that

cough

Now it works perfectly

Hi @Tamim, Try with this: (prompt "\nTo run a LISP type: reara") (princ) (defun c:reara ( / old_osmode base_blk spacing ss base_blk_pt dist_blk_lst len i ins_pt dist n dist_n x_cord y_cord new_pt) (setq old_osmode (getvar 'osmode)) (setvar 'osmode 0) (setq base_blk (car (entsel "\nPick the base block:\n")) spacing (getreal "\nEnter the spacing:\n") ) (prompt "\nSelect BLOCK's:") (setq ss (ssget (list (cons 0 "INSERT"))) base_blk_pt (cdr (assoc 10 (entget base_blk))) dist_blk_lst (list) ) (if (ssmemb base_blk ss) (ssdel base_blk ss) ) (setq len (sslength ss) i 0 ) (while (< i len) (setq ins_pt (cdr (assoc 10 (entget (ssname ss i)))) dist (distance base_blk_pt ins_pt) dist_blk_lst (cons (list dist (ssname ss i)) dist_blk_lst) i (1+ i) ) ) (setq dist_blk_lst (vl-sort dist_blk_lst (function (lambda (x1 x2) (< (car x1) (car x2))))) n 0 ) (repeat (length dist_blk_lst) (setq dist_n (- (car (nth n dist_blk_lst)) spacing (* spacing n)) x_cord (- (cadr (assoc 10 (entget (cadr (nth n dist_blk_lst))))) dist_n) y_cord (caddr (assoc 10 (entget (cadr (nth n dist_blk_lst))))) new_pt (list x_cord y_cord) ) (command-s "_move" (cadr (nth n dist_blk_lst)) "" (cdr (assoc 10 (entget (cadr (nth n dist_blk_lst))))) new_pt) (setq n (1+ n)) ) (setvar 'osmode old_osmode) (prompt (strcat "\nThe " (itoa (length dist_blk_lst)) " are rearanged!")) (princ) ) See the following video how it works. Rearange blocks.mp4 Best regards.

Sorry my fault it has a typo I fixed code above There should be a space after the "/" was missing in code posted, I sort the variable names and put in code missed the needed space. (defun c:brkobj ( / cenpt end1 end2 ent ent1 ent2 obj1 obj2 pt1 pt2 rad st1 st2 type ) It has a linetype, and Linetype Scale so change both of those to suit.

For me if you have an object and use Break. When selecting the first point you get an entity name ie ent1 Select 2nd point and run break pt1 pt2 Ok the second entity is (entlast) so no need for ssget's etc When you break say line pline the new object is created in the same direction so the gap is join endpoint ent1 to startpoint ent2. But as mentioned a circle and an arc need a slight variation on this. But still have a start and endpoint. Oh yeah a circle needs to be selected in an anti clockwise direction. Clockwise gives a big arc. Yes a break in the arc of a pline is an interesting problem. Or worse a part arc and straight. ; https://www.cadtutor.net/forum/topic/98693-break-an-object-at-2-points-and-replace-the-properties-of-the-line/ ; Break an object and use a different linetype ; Bu AlanH Sept 20205 (defun c:brkobj ( / cenpt end1 end2 ent ent1 ent2 obj1 obj2 pt1 pt2 rad st1 st2 type ) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 512) (setq ent (entsel "\nPick object 1st point to break at ")) (setq ent1 (car ent)) (setq pt1 (cadr ent)) (setq pt2 (getpoint "\nPick second point ")) (command "break" pt1 pt2) (setq ent2 (entlast)) (setq type (cdr (assoc 0 (entget ent1)))) (setq obj1 (vlax-ename->vla-object ent1)) (setq st1 (vlax-curve-getstartPoint obj1)) (setq end1 (vlax-curve-getendPoint obj1)) (setq obj2 (vlax-ename->vla-object ent2)) (setq st2 (vlax-curve-getstartPoint obj2)) (setq end2 (vlax-curve-getendPoint obj2)) (if (or (= type "LINE")(= type "LWPOLYLINE")) (progn (command "line"end1 st2 "") (command "chprop" (entlast) "" "LT" "DASHED" "s" 10 "") ) ) (if (= type "ARC") (progn (setq rad (vlax-get obj1 'radius)) (setq cenpt (vlax-get obj1 'center)) (command "arc" end1 "C" cenpt st2) (command "chprop" (entlast) "" "LT" "DASHED" "s" 10 "") ) ) (if (= type "CIRCLE") (progn (setq rad (vlax-get obj1 'radius)) (setq cenpt (vlax-get obj1 'center)) (command "arc" end1 "C" cenpt st1) (command "chprop" (entlast) "" "LT" "DASHED" "s" 10 "") ) ) (princ) ) (c:brkobj)

Do you need to use OpenDCl or can normal DCL be used ? Maybe explain what your trying to do in the DCL. There is some very smart DCL builders that post here.

So went ahead and joined my first part of mine and what Blackbox & Glavcvs posted. Can either run it by typing BD or BreakDash ;;----------------------------------------------------------------------------;; ;; Break Entities and changed layer, linetype, color (defun C:BD () (C:BreakDash) (princ)) (defun C:BreakDash (/ SS1 SS2 SS3 pt1 pt2 ent entdata newent) (setq SS2 (ssadd)) (while (setq SS1 (ssget "_+.:E:S" '((0 . "*LINE,CIRCLE,ARC")))) (setq ent (ssname SS1 0) pt1 (getpoint "Select the first break point: ") pt2 (getpoint "Select the second break point: ") LastEnt (entlast) ) (command-s "_.BREAK" ent pt1 pt2) (while (setq LastEnt (entnext LastEnt)) (ssadd LastEnt SS2) ) (setq SS3 (ssget "_W" pt1 pt2 '((0 . "LINE")))) (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex SS3))) (if (ssmemb ent SS2) (progn (entmod (append ent '((8 . "0") '(6 . "DASHED2") '(62 . 84)))) (entupd ent) ) ) ) ) (princ) ) And found Cab's post for break all objects

PS: Note that I have disabled (40 . 0.25) and (47 . 20) because they are rejected by most objects in your filter, and I haven't taken the time to find out which objects they actually apply to.

Hi As @mhupp mentioned, there are extra 'quotes' marks in your code. Also, as Mhupp suggested, you can use the filter "_+.:E:S" to select the object to be cropped in a single step, and then implement it within a 'while' loop to repeat the operation as many times as needed. Putting all of this together, your code could look something like this: (defun c:Br2ptReplDash (/ ss pt1 pt2 ent entdata newent entUlt) (while (setq ss (SETVAR "NOMUTT" 1) ss (princ "\nSelect object to trim (RIGH CLICK to EXIT)...") ss (ssget "_+.:E:S" '((0 . "*LINE,POLYLINE,CIRCLE,ARC"))) ) (SETVAR "NOMUTT" 0) (setq entUlt (entlast)) (princ "\nSelect the object to split: ") (setq ent (ssname ss 0)) ;; Entering the first break point (setq pt1 (getpoint "\nSelect the first break point: ")) ;; Entering the second break point (setq pt2 (getpoint "\nSelect the second break point: ")) ;; Checking the object type and performing the split (cond ((= (cdr (assoc 0 (entget ent))) "LWPOLYLINE") ;; break the LWPOLYLINE (command "_.BREAK" ent pt1 pt2) ) ((= (cdr (assoc 0 (entget ent))) "LINE") ;; break the line (command "_.BREAK" ent pt1 pt2) ) ((= (cdr (assoc 0 (entget ent))) "POLYLINE") ;; break polyline (command "_.BREAK" ent pt1 pt2) ) ((= (cdr (assoc 0 (entget ent))) "CIRCLE") ;; break the circle (command "_.BREAK" ent pt1 pt2) ) ((= (cdr (assoc 0 (entget ent))) "ARC") ;; break the arc (command "_.BREAK" ent pt1 pt2) ) (T (prompt "An object of an unsupported type.") ) ) (command "_.LINE" pt1 pt2 "") (if (not (equal entUlt (entlast))) (progn (entmod (append (ENTGET (ENTLAST)) '((8 . "0") ; the default layer (6 . "DASHED2") ; line type ;'(70 . 0) ;(40 . 0.25) ; thickness ;(47 . 20) (62 . 84) ) ) ; LTSCALE ) (princ "\nProcess completed for these objects") (vlr-beep-reaction) ) (princ "\n*** The operation could not be performed ***") ) ) (if (not entUlt) (princ "\nObjects are not selected.")) (princ) )

Entlast & entnext may help to mitigate that. 1+

You start the lisp with if this will only run once. changing the if to while will allow you to use the break command multiple of times with out having to type the command over and over. only draw back is if you only want to run the command once you have to right click or hit enter to exit the command. using ssget with the "_+.:E:S" acts like entsel and will only select entity's you define. eliminating the need to test the entity type. since you have the two break points defined you can use ssget with the window option to "select" that entity but could pick up other smaller unwanted items also. this is all moot because id recommend using Breakall by CAB. don't know if its on here but he posted it on theswamp.org many years ago. alot more features and error handling.

This is a bit more streamlined. ;; AutoLISP, which allows you to select objects (line, polyline, circle, arc), ;; break them at two points and replace the selected section with a dashed line with the specified parameters (defun c:Br2ptReplDash (/ SS pt1 pt2 ent entdata newent) ;while instead of if allows this command to be repated as long as you select an entity. (while (setq SS (ssget "_+.:E:S" '((0 . "LINE,POLYLINE,CIRCLE,ARC")))) ;Will emulate an entsel selection behaviour and only allows the entity types listed (progn ;no need for cond check now (setq ent (ssname SS 0)) (setq pt1 (getpoint "Select the first break point: ")) (setq pt2 (getpoint "Select the second break point: ")) Using the two points create a selection set window to pick up created break line (ssget "_W" pt1 pt2 '((0 . "LINE"))) Your entmod has to many ( ) (entmod (append newent '((8 . "0") ; the default layer '(6 . "DASHED2") ; line type '(40 . 0.25) ; thickness '(47 . 20) ; LTSCALE '(62 . 84) ; Add here instead of 2nd (entmod (append newent '((62 . 84)))) ) ) ) ;removed 2nd '(6 . "DASHED2")

I do not see any screen shots. Current Build [9.3.1.1] (The current build is always under development. It is where we add new features for testing. It's usually very stable, but may contain a few bugs.) Did you try the stable version? Stable Build [9.1.5.2] (The stable build has all the known bugs worked out, but may not be as up-to-date as the current build.) According to the response on the OpenDCL forum, those sub menus do not exist. Serious UI Failure in OpenDCL Studio - 'Options' and 'New Project' Menus are Mis As far as I can tell, AutoCAD 2021 was the first version for Windows 11, so there could be issues there.

@rlx will definitely have a look at it, your dcl stuff is great. One thing you can do is unzip a zip file using lisp, so could have all the files and a DAT file and save them to a known directory, as part of my Install.lsp it adds the support paths and load the toolbar. The reason for comment was I used CIV3D so I had a custom menu that had often used Civ3D commands, this saved having to change workspaces. You just have to open the CUI and copy the commands to say notepad.

Hi @rlx Is it possible that you forgot to include some functions that are called from your code? For example, 'rlx_sf'?

Hi I'm having trouble reconciling my understanding of your question with what I see in the example drawing. The square: doesn't it also play a role in determining the text justification? That is to say: if you select the upper right corner of the square and then specify a horizontal angle to the left, the justification should be bottom right. However, if you do the same thing starting from the lower right corner of the square, the MTEXT justification should be top right. Therefore, the idea seems to be that the MTEXT should always be positioned outside the square. Is this correct? In this case, the MTEXT angle criterion alone is not sufficient; it's also necessary to consider the object to which it refers. If all of this is correct, we would need to write a function that analyzes the geometry of the object the MTEXT refers to and determines the justification, taking the angle into account as well.

Sorry to hear that; I didn't know. Agree it's better to test if you have the data needed before entmake* functions. If you're wanting to get CAD back, consider joining AUGI as Pro members get a free ADN (Autodesk Developer Network) membership, which would give you any Autodesk product to use for development. https://www.augi.com/adn-membership-offer Cheers

After you account for '; error: too few arguments:'... Might also consider a single < comparer for limiting this to positive X quadrants, a neither 0 or pi check for all quadrants, etc: (if (and rot (< 0 rot pi)) ;check rotation angle (setq x 1) (setq x 7) ) (if (and rot (/= 0 rot) (/= pi rot)) ;check rotation angle (setq x 1) (setq x 7) ) (setq x (if (and rot (/= 0 rot) (/= pi rot)) ;check rotation angle 1 7 ) )

BLACKBOX for the WIN!! Thank you so very much.. Works perfectly now. Thank you both for the input.

Another maybe simpler this checks for Close and Save commands. yes got help from a couple of people like Lee-mac. ; by AlanH April 2023 ;Reactor callback function (defun BeginCloseFunc (reactor lst / blocks blk efname ent2 ent3 ole olelst ssole oletit olefound ss ssvft y tabname) (setq tabname (getvar 'ctab)) ; will get "Model" etc ............ do your thing here ........ ............ can call other defuns...... (princ) ) (cond ((= (vlr-current-reaction-name) ':VLR-beginSave) (Princ "\nThis function has been triggered by a Document Save event.")) ((= (vlr-current-reaction-name) ':VLR-beginClose)(princ "\nThis function has been triggered by a Document Close event.")) ) (princ) ) (if (not _BeginCloseReactor) (setq _BeginCloseReactor (VLR-Dwg-Reactor nil '((:VLR-beginClose . BeginCloseFunc))))) (if (not _BeginSaveReactor ) (setq _BeginSaveReactor (VLR-Dwg-Reactor nil '((:VLR-beginSave . BeginCloseFunc)))))

yes the list is just a plain text file. Seems there still is a gremlin in the app , have to hunt it down... think starting setup dialog while toolbar is active is the culprit, probably better to have tootlbar and setup separate. I will have a look at this.

could you type or speak a little louder because I can't hear you Steven

It was more of a qualifier... While I'm sure they exist, I've never personally met anyone who used Python and couldn't compile .NET Haha