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.

(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.

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

Try this. Not sure what you want for attribute values. Can ask once then will be added correctly. Maybe 3 getstring after pick pline. ; https://www.cadtutor.net/forum/topic/98666-block-insert-lisp/ ; arrows by AlanH Aug 2025 (defun c:wow ( / plent co-ord isclosed x obj ang) ;; Set Dynamic Block Property Value - Lee Mac ;; Modifies the value of a Dynamic Block property (if present) ;; blk - [vla] VLA Dynamic Block Reference object ;; prp - [str] Dynamic Block property name (case-insensitive) ;; val - [any] New value for property ;; Returns: [any] New value if successful, else nil (defun LM:setdynpropvalue ( blk prp val ) (setq prp (strcase prp)) (vl-some '(lambda ( K ) (if (= prp (strcase (vla-get-propertyname k))) (progn (vla-put-value K (vlax-make-variant val (vlax-variant-type (vla-get-value K)))) (cond (val) (t)) ) ) ) (vlax-invoke blk 'getdynamicblockproperties) ) ) (setq plent (entsel "\nPick pline")) (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car plent))))) (setq isclosed (cdr (assoc 70 (entget (car plent))))) (setq x 0) (command "-insert" "Stalb" (nth x co-ord) 1 1 0 "" "" "") (setq obj (vlax-ename->vla-object (entlast))) (setq ang (angle (nth x co-ord) (nth (+ x 1) co-ord))) (LM:setdynpropvalue obj "Angel_1" ang) (if (= isclosed 1) (progn (setq ang (angle (nth 0 co-ord) (last co-ord) )) (LM:setdynpropvalue obj "Angel_2" ang) ) ) (repeat (- (length co-ord) 2) (command "-insert" "Stalb" (nth (setq x (1+ x)) co-ord) 1 1 0 "" "" "") (setq obj (vlax-ename->vla-object (entlast))) (setq ang (angle (nth x co-ord) (nth (+ x 1) co-ord))) (LM:setdynpropvalue obj "Angel_1" ang) (setq ang (angle (nth x co-ord) (nth (- x 1) co-ord))) (LM:setdynpropvalue obj "Angel_2" ang) ) (command "-insert" "Stalb" (nth (setq x (1+ x)) co-ord) 1 1 0 "" "" "") (setq obj (vlax-ename->vla-object (entlast))) (setq ang (angle (nth x co-ord) (nth (- x 1) co-ord))) (LM:setdynpropvalue obj "Angel_2" ang) (if (= isclosed 1) (progn (setq ang (angle (nth x co-ord) (nth 0 co-ord) )) (LM:setdynpropvalue obj "Angel_1" ang) ) ) (princ) )

Notepad ++ can set the save mode it has numerous options including Ansi and UTF-8.

I think you've solved the problem very well. In response to your request for improvements or suggestions, I've provided some minor modifications below that, in my opinion, make the command more intuitive. (defun c:LE-CalExtFFL ( / pt1 pt2 pt3 r TxtRotation TxtJustification radians degrees ecoA) (setq ecoA (getvar "CMDECHO")) (setvar "CMDECHO" 0) (vla-startUndomark (vla-get-activeDocument (vlax-get-acad-object))) (command "_layer" "_m" "-LE-E-External Levels" "") (setq Prefix "") (setq Suffix "") (setq ffl-ent (car (entsel))) (if (and ffl-ent (= (cdr (assoc 0 (entget ffl-ent))) "MTEXT")) (setq r (vl-catch-all-apply '(lambda () ;; Get the MText object and extract text content (setq ffl-obj (entget ffl-ent)) (setq ffl-text (cdr (assoc 1 ffl-obj))) (princ (strcat "\nFFL Text found: " ffl-text)) (setq ffl-value (ExtractFFLValue ffl-text)) (princ "\nSelect points where to place the level text (Press Enter to finish): ") (if ffl-value (if (setq pt1 (getpoint "\nSelect first point: ")) (if (setq pt2 (getpoint pt1 "\nSelect second point: ")) (virtualiza) ) ) ) ) ) ) ) (if r (entdel (entlast))) (setvar "CMDECHO" ecoA) (princ) ) (defun virtualiza (/ para grd mto) (princ "\nMove the mouse to decide justification (escape to CANCEL)...") (while (and (not para) (setq grd (grread nil 13 0)) (listp (cadr grd))) (setq pt3 (cadr grd)) (setq SpotLevel (- ffl-value 0.15)) ;; Initialize point list ;; Prompt for points where to place the new MText (setq TxtRotation (angle pt1 pt2)) (setq TxtValue SpotLevel) (DefMTextJustification pt1 pt2 pt3) (if mto (entmod (subst (cons 71 TxtJustification) (assoc 71 (entget mto)) (entget mto))) (setq mto (CreateMText pt1 TxtValue TxtRotation TxtJustification)) ) (if (= (car grd) 3) (setq para T)) ) (vla-EndUndomark (vla-get-activeDocument (vlax-get-acad-object))) ) (defun ExtractFFLValue (text-string / clean-text) (if (> (strlen text-string) 5) ;Charcters Removed from String (setq clean-text (substr text-string 6)) (setq clean-text text-string) ) (if (numberp (read clean-text)) (read clean-text) (progn (princ "\nError: Could not extract numeric value from FFL text.") nil ) ) ) (defun DefMTextJustification ( p1 p2 p3 / ) ;; Top Left = 1 ;; Top Center = 2 ;; Top Right = 3 ;; Middle Left = 4 ;; Middle Center = 5 ;; Middle Right = 6 ;; Bottom Left = 7 ;; Bottom Center = 8 ;; Bottom Right = 9 (if (or (and (>= (angle p1 p2) 0.0) (<= (angle p1 p2) (/ PI 2.))) (>= (angle p1 p2) (/ (* 3. PI) 2.))) (progn (setq TxtJustification 1) (setq Prefix "+") (setq Suffix "") (if (> (angle p1 p3) (angle p1 p2)) (progn (setq TxtJustification 7) (setq Prefix "+") (setq Suffix "") (if (and (= (angle p1 p2) 0.0) (> (angle p1 p3) 4.71238898)) (progn (setq TxtJustification 1) (setq Prefix "+") (setq Suffix "") ) ) ) ) ) (progn (setq TxtJustification 3) (setq Prefix "") (setq Suffix "+") (setq TxtRotation (+ TxtRotation pi)) ;;Set Justification to Bottom (if (> (angle p1 p3) (angle p1 p2)) (progn (setq TxtJustification 3) (setq Prefix "") (setq Suffix "+") ) (progn (setq TxtJustification 9) (setq Prefix "") (setq Suffix "+") ) ) ) ) ) (defun CreateMText ( point txtvalue txtrot txtjust / txtjust txtrot mtext-obj) (setq mtext-obj (entmakex (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 8 (getvar "CLAYER")) ; Current layer (cons 100 "AcDbMText") (cons 10 point) ; Insertion point (cons 40 0.5) ; Text height (adjust as needed) (cons 41 0.0) ; Reference rectangle width (cons 71 txtjust) (cons 72 5) ; Drawing direction (cons 1 (strcat Prefix (rtos txtvalue 2 3) Suffix)) ; Text content with "+" prefix (cons 50 txtrot) ; Rotation angle ) ) ) mtext-obj )

Another important detail: in the circles, the resulting arc that will be modified depends on whether the cut points are indicated in a clockwise or counterclockwise direction. If they are selected in the opposite direction from what is needed to obtain the desired result, it can be immediately switched by pressing TAB key (as indicated in the command line).

I think I read your first explanation too quickly. I also thought about keeping the main part of your code to avoid overcomplicating my answer. But in the end, I decided to spend a little time improving the code. Here's another option for doing this task. One possible difference (or not) with the other options discussed in this thread is that the cut points may or may not be on the object to be cut: when they aren't, it will calculate the perpendicular point. Another small difference is that here, you're still required to first select the object to be modified to avoid the problem of cases where several objects coincide at the same point. (defun c:Br2ptReplDash (/ para tl ss pt1 pt2 p1 p2 ent vlae ep to c r eumk entdata newent entUlt osmant ecoA lstChg lstR lent1 lent pIni pFin dameSeg *troca* erroria errores error0 ) (defun erroria () (defun errores (mens) (setq *error* error0) (command-s "._undo" "_1") (prin1) ) (setq error0 *error* *error* errores ) ) (defun dameSeg (e p1 p2 / vlae pIni pFin rg) (setq pIni (vlax-curve-getPointatParam (setq vlae (vlax-ename->vla-object e)) (vlax-curve-getStartParam vlae)) pFin (vlax-curve-getPointatParam vlae (vlax-curve-getEndParam vlae)) rg (* (getvar "PICKBOX") (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))) 1.01) ) (if (and (or (equal p1 pIni rg) (equal p1 pFin rg) ) (or (equal p2 pIni rg) (equal p2 pFin rg) ) ) T ) ) (defun grreadea (/ para lr ) (while (not para) (princ "\rPress TAB to switch modifications, Select next object to split or RIGHT CLICK to EXIT...") (setq lr (grread T 4 2)) (cond ((= (car lr) 2) (cond ((= (cadr lr) 9) (setq *troca* (not *troca*)) (entmod (append (if *troca* lent lent1) lstChg)) (entmod (append (if *troca* lent1 lent) lstR)) ) ) ) ((= (car lr) 25) (setq para 0 ep nil) ) ((= (car lr) 3) (if (listp (cadr lr)) (setq ep (nentselp (cadr lr)) ep (if (wcmatch (cdr (assoc 0 (entget (car ep)))) "*LINE,ARC,CIRCLE") ep) para (if ep T) ) ) ) (T (if (/= (car lr) 5) (print lr) )) ) ) para ) (erroria) (setq osmant (getvar "OSMODE") ecoA (getvar "CMDECHO") eumk nil tl "DASHED2" tl (if (tblsearch "LTYPE" tl) tl (progn (vlr-beep-reaction) (alert (princ (strcat "\n*** Linetype " tl " not found. It will be instead CONTINUOUS"))) "CONTINUOUS" ) ) lstChg (list '(8 . "0") ; the default layer (cons 6 tl) ; line type '(48 . 0.25) ; thickness '(62 . 84) ; color ) ) (setvar "CMDECHO" 0) (while (and (not para) (or ep (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 (if ep (car ep) (ssname ss 0)) lstR (list (cons 6 (if (assoc 6 (entget ent)) (cdr (assoc 6 (entget ent))) "BYLAYER")) (cons 48 (if (assoc 48 (entget ent)) (cdr (assoc 48 (entget ent))) 1.0)) (cons 62 (if (assoc 62 (entget ent)) (cdr (assoc 62 (entget ent))) 256)) ) ) (setq pt1 (getpoint "\nSelect the first break point: ") ;; Entering the first break point pt2 (getpoint "\nSelect the second break point: ") ;; Entering the second break point ep nil ) (vla-startUndomark (vla-get-activeDocument (vlax-get-acad-object))) ;; Checking the object type and performing the split (cond ((wcmatch (setq to (cdr (assoc 0 (entget ent)))) "*LINE") ;; break polyline (setq pt1 (vlax-curve-getClosestPointTo (vlax-ename->vla-object ent) pt1) pt2 (vlax-curve-getClosestPointTo (vlax-ename->vla-object ent) pt2) ) (command "_.BREAK" ent pt1 pt2) (command "_.LINE" pt1 pt2 "") (entmod (append (ENTGET (ENTLAST)) lstChg)) ) ((= to "CIRCLE") ;; break the circle (setvar "OSMODE" 0) (entmake (entget ent)) (command "_.BREAK" ent pt1 pt2) (command "_.BREAK" (entlast) pt2 pt1) (setq lent (entget ent)) (entmod (append (setq lent1 (entget (entlast))) lstChg)) (setq para (= 0 (grreadea))) ) ((= to "ARC") ;; break the arc (setvar "OSMODE" 0) (setq ;ent1 (entmake (entget ent)) pIni (vlax-curve-getPointatParam (setq vlae (vlax-ename->vla-object ent)) (vlax-curve-getStartParam vlae)) pFin (vlax-curve-getPointatParam vlae (vlax-curve-getEndParam vlae)) pt1 (polar (setq c (cdr (assoc 10 (setq lent (entget ent))))) (angle c pt1) (setq r (cdr (assoc 40 lent)))) pt2 (polar c (angle c pt2) r) ) (command "_.BREAK" ent pt1 pt1) (if (equal (car (nentselp pt2)) (setq ent1 (entlast))); SI P2 EST脕 SOBRE LA NUEVA ENTIDAD CREADA (command "_.BREAK" ent1 pt2 pt2) (command "_.BREAK" ent pt2 pt2) ) (entmod (append (entget (if (dameSeg (setq ent2 (entlast)) pt1 pt2) ent2 ent1)) lstChg)) ) (T (prompt "An object of an unsupported type.") ) ) (vla-EndUndomark (vla-get-activeDocument (vlax-get-acad-object))) (setq eumk T) (setvar "OSMODE" OSMANT) ) (if ecoA (setvar "CMDECHO" ecoA)) (if (not entUlt) (princ "\nObjects are not selected.")) (princ) )

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>

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

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

you're welcome. The 'secret' when going MDI is using vla commands only.

Hola de nuevo, Offsetea.mp4 Dejé una tarea pendiente en este hilo que intentaré cerrar. Adjunto una nueva versión de Offsetea . A continuación, explico el comportamiento y las opciones del comando. Partimos de una lógica de trabajo basada en el enfoque del código de Evgeny Elpanov. De hecho, esta lógica es más fácil de explicar en código que con palabras: proyectar un segmento entre dos vectores guía (definidos por los extremos del segmento y el punto que precede a cada uno de ellos) que se intersecan en un punto, que se convierte en el foco de la proyección. Al proyectar segmentos rectos, el resultado solo puede ser uno. Sin embargo, en el caso de segmentos de arco, ¿qué ocurre si reemplazamos el foco de proyección? En base a esto, se me ocurrieron dos opciones adicionales: el centro y el polo del arco. También consideré la posibilidad de añadir una tercera opción que permitiera al usuario especificar la ubicación del foco en pantalla. Sinceramente, no creo que esto sea útil (espero que al menos una de las otras dos lo sea ). Así, la funcionalidad del comando es la siguiente: - Selección del segmento de polilínea a proyectar: el comando solo funcionará si la polilínea está compuesta por 2 o más segmentos. Si el segmento seleccionado es recto , los vectores guía se definirán por sus extremos y el punto anterior de cada uno (es decir, los segmentos adyacentes). Si uno de los extremos del segmento es también un extremo de la polilínea, el vector guía para ese extremo será la normal a él. Si el segmento es un arco , los vectores guía predeterminados serán los mismos que para los segmentos rectos (propuesta de Evgeny). Sin embargo, aquí es posible cambiar el enfoque del enfoque secante de Evgeny (tecla '2') al enfoque radial (tecla '1') o al enfoque tangente (tecla '3'). En cuanto a las herramientas de control del segmento a proyectar, he implementado un ajuste al estilo GLAVCVS , limitado a los casos posibles para este comando: _end, _mid, _int, _cen, _nod, _ins, _nea. Este ajuste se puede activar o desactivar con F3. La relación entre la posición del cursor y el segmento a proyectar siempre será de seguimiento de segmento en los segmentos rectos. Sin embargo, en los segmentos de arco, puede ser de seguimiento de arco o de cuerda. Para alternar entre ambos, simplemente pulse TAB. El seguimiento de arco está activo mientras el cursor permanece entre los dos vectores de proyección. De lo contrario, cambia automáticamente al seguimiento de cuerda. La diferencia entre ambos radica, por lo tanto, en el comportamiento cuando el cursor se encuentra entre los vectores guía. Estos vectores guía se muestran en pantalla como dos líneas discontinuas rojas. Junto al cursor se muestra texto informativo en tiempo real: Para segmentos rectos (de arriba a abajo): la distancia de desplazamiento desde la ubicación inicial y la longitud del segmento. Para segmentos de arco: distancia de desplazamiento desde la ubicación inicial, radio del arco, longitud del arco y longitud de la cuerda. La visibilidad de esta información se puede activar o desactivar con la tecla "i" . Por último, puedes aumentar o disminuir el tamaño de los indicadores junto al cursor presionando las teclas '+' o '-'. En cuanto al rendimiento del comando, mientras escribía el código, descubrí una mayor variedad de casos de los que inicialmente había pensado. Si el objetivo principal era lograr el seguimiento del segmento de arco según la posición del cursor, creo que este código cubrirá aproximadamente el 90 % de los casos posibles. En los casos donde no sea posible el seguimiento del arco, se realizará a nivel de la cuerda. Espero que a alguien le resulte útil. Offsetea_v2.lsp

There was a thread a few days ago about speeding up a LISP to do the same, have look at that for ideas. I think the thread got as far as arcs are tricky to do with LISPs. You could use the flatten command for small drawings. This snippet will filter a selection set to lines or LWPolylines to anything not 0 Z (setq MySS (ssget (list (cons 0 "*TEXT,INSERT,LINE,LWPOLYLINE") '(-4 . "<OR") '(-4 . "*,*,<>") (list 10 0.0 0.0 0.0) '(-4 . "*,*,<>") (list 11 0.0 0.0 0.0) '(-4 . "<>") (cons 38 0) '(-4 . "OR>") )) ; end list, end ssget ) Can be added to the other solutions herein the case that your drawing has a lot of lines / polylines / blocks it speeds it up a bit Link to other thread:

As a spline gives two answers the points answer and another with nodes. So any way if you explode the Mleader then you can get at the spline using this. Just need to check that the spline is last entity, tested in Bricscad. A disclaimer not sure if length is correct. I think it is short by length of arrow. Will try to find arrow length. Yep found it. (defun c:wow ( / plent pt len lenar) (setq plent (entsel "\nPick mleader ")) (setq lenar (cdr (assoc 140 (entget (car plent))))) (command "undo" "M") (command "explode" (car plent)) (setq ent (ssname (ssget "L") 0)) (setq len (getpropertyvalue ent "length")) (command "undo" "B") (alert (strcat "Total length is " (rtos (+ lenar len) 2 3))) (princ) ) (c:wow) I think you could do a "I want a length of 100 by drawing something close then move say arrow point till you get approx 100. Via lisp. It would be a two step process explode and move then undo and reset arrow head point.

Try an another version (vl-load-com) (defun c:BLOCKINSERT ( / ss blkname acadObj doc mspace n dxf_ent vlaobj pr nb_e scl_blk pt lst_pt nbs ang1 ang2 blk lst itm) (setq ss (ssget '((0 . "*POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 112) (-4 . "NOT>"))) blkname "Stalb" ) (cond ((and ss (tblsearch "BLOCK" blkname)) (setq acadObj (vlax-get-acad-object) doc (vla-get-activedocument acadObj) mspace (vla-get-modelspace doc) ) (if (null (tblsearch "LAYER" "EL_стълб_НН")) (vlax-put (vla-add (vla-get-layers doc) "EL_стълб_НН") 'color 1) ) (repeat (setq n (sslength ss)) (setq dxf_ent (entget (setq ent (ssname ss (setq n (1- n))))) dxf_210 (cdr (assoc 210 dxf_ent)) lst_pt nil) (setq vlaobj (vlax-ename->vla-object ent) pr -1 ) (repeat (setq nb_e (if (zerop (vlax-get vlaobj 'Closed)) (1+ (fix (vlax-curve-getEndParam vlaobj))) (fix (vlax-curve-getEndParam vlaobj)))) (if (not scl_blk) (progn (initget 6) (setq scl_blk (getreal "\nBlock scale?<1>: ")))) (if (not scl_blk) (setq scl_blk 1.0)) (setq pt (vlax-curve-GetPointAtParam vlaobj (setq pr (1+ pr))) lst_pt (cons pt lst_pt) ) (setq nbs (1- (length lst_pt))) ) (foreach pto lst_pt (if (and (not (zerop nbs)) (not (eq (1+ nbs) (length lst_pt)))) (setq ang1 (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj nbs)) ang2 (+ pi (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj (1- nbs)))) ) (setq ang1 (if (not (zerop nbs)) (+ pi (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj (1- nbs)))) (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj nbs)) ) ang2 ang1 ) ) (if (and (zerop nbs) (not (zerop (vlax-get vlaobj 'Closed)))) (setq ang1 (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj nbs)) ang2 (+ pi (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj (length lst_pt)))) ) ) (if (and (eq (1+ nbs) (length lst_pt)) (not (zerop (vlax-get vlaobj 'Closed)))) (setq ang1 (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv vlaobj nbs)) ) ) (setq nbs (1- nbs) blk (vla-InsertBlock mspace (vlax-3d-point pto) blkname scl_blk scl_blk scl_blk 0.0) ) (vlax-put blk 'Layer "EL_стълб_НН") (vlax-put blk 'Color 3) (setq lst (list (cons "Angel_1" ang1) (cons "Angel_2" ang2))) (foreach x (vlax-invoke blk 'getdynamicblockproperties) (if (setq itm (assoc (vla-get-propertyname x) lst)) (vla-put-value x (vlax-make-variant (cdr itm) (vlax-variant-type (vla-get-value x)))) ) ) ) ) ) ) (prin1) )

Agree with @GLAVCVS, with cadr you're getting the X coordinate, not Y coordinate.

Is the coordinate order set to Y, X, Z? This could be the error. Try changing cadr to caddr in the line '(setq yval (cadr (assoc 10 edata)))'

If its part of your language and not some type of random ascii your using. with a fresh install of windows the language probably needs to be updated in the settings.

Hi Start by checking which ANSI setting you have on your new OS. Control Panel → Region → Administrative tab → Change system locale button. The system locale should appear in Spanish and the option 'Version beta: Use UTF-8...' should be unchecked.

You could potentially use my Import Block application, which is specifically targeting blocks.

You haven't defined "arrowAng" variable and you are using it in (polar) function... Sorry, my mistake - you defined it firstly... [EDIT : You should changle variable "angle" to something different like "ang" as (angle) is AutoLISP function and then you should localize "ang" in main (defun) instead of "angle"...]

Change elevation only works if all points are on the same Z elevation. this might be why also flatten isn't working for you. Two things you can do to speed up. Combine all the commands into one call like you did below Command has some type of "lag" but for example lets just call it 100ms this would remove 500ms for each loop. Not to mention all the command line spam. (setvar cmdecho 0) when you sent LastEnt anything created or modified is "behind" LastEnt in the drawing and can be added to a selection set with a simple loop. rather then selecting everything in the drawing and checking against the before selection set to find the new items. (setq zList '()) ;(setq before (ssget "_X")) ;not needed anymore (command "regen" "_.copy" obj "" '(0 0 0) '(0 0 0)) (setq LastEnt (entlast)) ;set right before you create/modify objects. you want to either add to a selection (command "_.explode" newent) (while (setq LastEnt (entnext LastEnt)) ;after entities are created this will add them to a selection set. (ssadd LastEnt newents) ) (foreach e newents -edit typo in code

Just to amuse myself, here is a snippet that will flatten simple entities, not sure if that helps you along the way - you can use what code works for 3d polylines, hatches, regions and blocks - might be a bit quicker Command: NewFlatten An edit for later... (defun FlattenLines ( Pt1 Pt2 / MySS MyEnt acount ed) ;;For arcs, attdef, circle, (dimension N/A), Insert, Line, LWPolyline, Mtext, Point, text, ;;Does lines, circles, arcs, ellipses, texts, LWPolylines (if (< (car pt1)(car pt2)) (setq MySS (ssget "_W" pt1 pt2 (list '(-4 . "<OR") '(-4 . "*,*,<>") (list 10 0.0 0.0 0.0) '(-4 . "*,*,<>") (list 11 0.0 0.0 0.0) '(-4 . "<>") (cons 38 0) '(-4 . "OR>") ))) ; end list, ssget, setq (setq MySS (ssget "_C" pt1 pt2 (list '(-4 . "<OR") '(-4 . "*,*,<>") (list 10 0.0 0.0 0.0) '(-4 . "*,*,<>") (list 11 0.0 0.0 0.0) '(-4 . "<>") (cons 38 0) '(-4 . "OR>") ))) ; end list, ssget, setq ) ; end f ; (setq MySS (ssget "_X" (list ; '(-4 . "<OR") ; '(-4 . "*,*,<>") (list 10 0.0 0.0 0.0) ; '(-4 . "*,*,<>") (list 11 0.0 0.0 0.0) ; '(-4 . "<>") (cons 38 0) ; '(-4 . "OR>") ; ))) ; end list, ssget, setq (setq acount 0) (while (< acount (sslength MySS)) (setq MyEnt (ssname MySS acount)) (setq ed (entget MyEnt)) (if (equal (assoc 0 ed) (cons 0 "LWPOLYLINE")) (progn (entmod (setq ed (subst (cons 38 0) (assoc 38 ed) ed) )) ;; Elevation to 0 ) ; end progn (progn (entmod (setq ed (subst (cons 10 (mapcar '* '(1 1 0) (cdr (assoc 10 ed)))) (assoc 10 ed) ed)) ) (entmod (setq ed (subst (cons 11 (mapcar '* '(1 1 0) (cdr (assoc 11 ed)))) (assoc 11 ed) ed)) ) ) ; end progn ) ; end if (setq acount (+ acount 1)) ) ; end while ) (defun SSMouseOrder ( / MyList MySS pt1 pt2 MyEnt SelSS MySS MyDuir acount) ;; Enttypelist: wildcards are OK but not for single selection. ;; Enttypelist in CAPITALS for single entity selection to work. (princ " (Crossing selection, not single picks please). ") ;;Set up LISP (setq MySS (ssadd)) ;; Blank Selelection Set (if (= EntTypeList nil)(setq EntTypeList (list "LINE" "ARC" "CIRCLE")) ) ;; default entity filter (setq MyList (list (cons -4 "<OR") )) ;; Create filter to use with ssget (foreach n EntTypeList (setq MyList (append MyList (list (cons 0 n)) ) ) ) ; end foreach (setq MyList (append MyList (list (cons -4 "OR>")) ) ) (while (setq pt1 (getpoint "Select Objects:"));; Loop to select entities (setq pta pt1) ; record pt1 selected (if (setq MyEnt (car (nentselp pt1))) ;; If 1st point selected was on an entity: Single entity selected (progn (if (ssdel MyEnt MySS) ;; If entity is in selected selection set, delete it (progn (redraw MyEnt 4) ;; Take away highlight ) (progn ;; Else add single entity to selection set (If (member (cdr (assoc 0 (entget MyEnt))) EntTypeList) ;;Check entity type is desired (progn (setq MySS (ssadd MyEnt MySS)) ;; Add to selection set (princ (strcat " 1 Found, ")) ;; Report selection found (redraw MyEnt 3) ;; highlight entity ) ; end progn ) ; end if member ) ; end progn ) ; end if ssdel ) ; end progn (progn ;; Else if clicked point not an entity (setq pt2 (getcorner pt1 " Specify Opposite Corner")) ;;get 2nd point (if (< (car pt1)(car pt2)) ;; Left to right, right to left to determine window or crossing filter (setq SelSS (ssget "_W" pt1 pt2 MyList) ) ;; Get selected entities (setq SelSS (ssget "_C" pt1 pt2 MyList) ) ) (setq acount 0) (if SelSS ;; If anything was selected (progn (princ (strcat " " (rtos (sslength SelSS) 2 0) " Found, ")) ;; report how many entities selected (while (< acount (sslength SelSS)) ;; add entities to selection set (setq MySS (ssadd (ssname SelSS acount) MySS)) (redraw (ssname SelSS acount) 3) ;; Highlight each entity (setq acount (+ acount 1)) ;; Loop counter ) ; end while ) ; end progn ) ; end if SelSS ) ; end progn ) ; end if MyEnt (setq MyDir 0) ;; Work out mouse click directions. Note single selection direction is LL->UR (if (< (cadr pt1)(cadr pt2)) ;; Horizontal (setq MyDir 0) (setq MyDir 1) ) (if (< (car pt1)(car pt2)) ;; Vertical (setq MyDir (+ MyDir 0)) (setq MyDir (+ MyDir 2)) ) ) ; end while (setq acount 0) ;; clear highlights (while (< acount (sslength MySS)) (redraw (ssname MySS acount) 4) (setq acount (+ acount 1)) ) (if (= (sslength MySS) 0) ;; report the selection set and direction or nil if no selection nil (list MySS MyDir) ;; MyDir: 0 BL->TR (or point selection), 1 TL->BR, 2 BR->TL, 3 TR->BL ) (list pta pt2 MyDir) ; MyDir 0, 1-> L to R, 2, 3 -> R to L ) (defun c:NewFlatten ( / Pts) (princ "Selection: ") (setq Pts (SSMouseOrder)) ;;Mouse order returns Selection set points. Used later. (FlattenLines (car Pts) (cadr Pts) ) ;; flatten simple entities ) ; end defun

Depends what you are using for obj, if it is an entity name this is a bit quicker: (command "_.copy") (command obj) (command "") (command '(0 0 0) '(0 0 0)) (setq newent (entlast)) (command "_.explode" newent) becomes (command "_.Explode" (setq NewEnt (entmakex (entget obj)) ) ) where obj might be from (car (entsel)) or (ssname MySS number) Might want to look at the number of loops in the snippet you posted

Can't really tell you how to optimize code you didn't post, but when people first get into lisp the rely heavily on command because its follows what you would type into the command line. It become apparent in a loop processing 1000's of entity's that its quite inefficient. rather then using entmod or some other way to update model. If flatten doesn' work also try the command Change > elevation > 0

If you don't want the command to end after editing the text, you can keep the "while" loop, as shown in this other code. The operation will be the same except that to exit the command, you'll need an additional "right click." (defun c:TEcolor136_230 (/ error oldcmdecho sel e typo obj res currentColor para) (vl-load-com) (defun error (msg) (if oldcmdecho (setvar "CMDECHO" oldcmdecho) ) (if (and msg (not (wcmatch (strcase msg) "BREAK,CANCEL,EXIT"))) (princ (strcat "Error: " msg)) ) (princ) ) (setq oldcmdecho (getvar "CMDECHO")) (setvar "CMDECHO" 0) (while (setq sel (entsel "\nSelect TEXT/MTEXT to edit (Enter — exit): ")) (setq ;sel (entsel "\nSelect TEXT/MTEXT to edit (Enter — exit): ") e (car sel) typo (strcase (cdr (assoc 0 (entget e)))) ) (if (wcmatch typo "TEXT,MTEXT") (progn (setq obj (vlax-ename->vla-object e)) ;; get the current color (setq currentColor (vl-catch-all-apply 'vlax-get-property (list obj 'Color)) ) ;; Error handling on receipt (if (vl-catch-all-error-p currentColor) (setq currentColor 0) ) ;; Opening the text editor (getstring) (setq res (vl-catch-all-apply 'vl-cmdf (list "_.textedit" e "")) ) ;;; (if (/= (setq res (getstring (strcat "\nEdit text <" (cdr (assoc 1 (entget e))) ">: "))) "") ;;; (entmod (subst (cons 1 res) (assoc 1 (entget e)) (entget e))) ;;; ) (if (vl-catch-all-error-p res) (princ "Editing canceled.") ;; After editing, we change the color (progn (if (= currentColor 136) ;; If it's 136, change it to 230. (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-put-property (list obj 'Color 230) ) ) (princ "Couldn't change color to 230.") (princ "The color has been changed to 230.") ) ) (if (/= currentColor 136) ;; If it's not 136, change it to 136. (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-put-property (list obj 'Color 136) ) ) (princ "Couldn't change the color to 136.") (princ "The color has been changed to 136.") ) ) (princ "Editing completed.") ) ) ) (princ "It's not an object TEXT/MTEXT.") ) ) (setvar "CMDECHO" oldcmdecho) (princ) )

There's another option: to respect the call to 'textedit' and exit it by clicking the mouse over the empty background. This is the option applied in the attached code. (defun c:TEcolor136_230 (/ error oldcmdecho sel e typo obj res currentColor para) (vl-load-com) (defun error (msg) (if oldcmdecho (setvar "CMDECHO" oldcmdecho) ) (if (and msg (not (wcmatch (strcase msg) "BREAK,CANCEL,EXIT"))) (princ (strcat "Error: " msg)) ) (princ) ) (setq oldcmdecho (getvar "CMDECHO")) (setvar "CMDECHO" 0) ;;; (while (setq sel (entsel "\nSelect TEXT/MTEXT to edit (Enter — exit): ")) (setq sel (entsel "\nSelect TEXT/MTEXT to edit (Enter — exit): ") e (car sel) typo (strcase (cdr (assoc 0 (entget e)))) ) (if (wcmatch typo "TEXT,MTEXT") (progn (setq obj (vlax-ename->vla-object e)) ;; get the current color (setq currentColor (vl-catch-all-apply 'vlax-get-property (list obj 'Color)) ) ;; Error handling on receipt (if (vl-catch-all-error-p currentColor) (setq currentColor 0) ) ;; Opening the text editor (getstring) (setq res (vl-catch-all-apply 'vl-cmdf (list "_.textedit" e "")) ) ;;; (if (/= (setq res (getstring (strcat "\nEdit text <" (cdr (assoc 1 (entget e))) ">: "))) "") ;;; (entmod (subst (cons 1 res) (assoc 1 (entget e)) (entget e))) ;;; ) (if (vl-catch-all-error-p res) (princ "Editing canceled.") ;; After editing, we change the color (progn (if (= currentColor 136) ;; If it's 136, change it to 230. (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-put-property (list obj 'Color 230) ) ) (princ "Couldn't change color to 230.") (princ "The color has been changed to 230.") ) ) (if (/= currentColor 136) ;; If it's not 136, change it to 136. (if (vl-catch-all-error-p (vl-catch-all-apply 'vlax-put-property (list obj 'Color 136) ) ) (princ "Couldn't change the color to 136.") (princ "The color has been changed to 136.") ) ) (princ "Editing completed.") ) ) ) (princ "It's not an object TEXT/MTEXT.") ) ;;; ) (setvar "CMDECHO" oldcmdecho) (princ) )

I think you need one ENTER to exit from 'textedit' and another one to exit from the while loop. I think It’s not possible to solve everything with a right click. The only option that comes close to what you’re asking for is to remove the while loop, so that the command ends after editing each text. But this will force you to press right click to repeat the command. The only option that would allow what you’re describing is to edit the text content with getstring instead of textedit. But I don’t know if you’re willing to do that.

Why not check the color 1st change the color then edit it ? Also you can shorten the get put property. Must be a vl object. (setq colorobj (vlax-get obj 'color)) (vlax-put obj 'color 230) Maybe this also ;; If it's 136, change it to 230. (if (= currentColor 136) (vlax-put obj 'color 230) (vlax-put obj 'color 130) ) To select only *text you can use a ssget (while (setq ss (ssget '(( 0 . "*TEXT")))) (setq e (ssname ss 0)) (setq obj (vlax-ename->vla-object e)) Have a look at Lee-mac SSGET functions look at the E: option.

Another ; make table example ; By Alan H 2018 ; updated for post https://www.cadtutor.net/forum/topic/98664-tables/ Aug 2025 (defun c:maketableXY (/ colwidth numcolumns numrows objtable rowheight sp vgad vgao vgms) (vl-load-com) (setvar "osmode" 0) (setq bm (ssget '((0 . "LINE")))) (if bm (progn (setq num (sslength bm)) (setq i 0) (setq point_list '()) (repeat num (setq obj (ssname bm i)) ; Get entity name (setq db (entget obj)) ; Get entity data (setq p1 (cdr (assoc 10 db))) ; Start point (setq p2 (cdr (assoc 11 db))) ; End point (setq midpt (mapcar '/ (mapcar '+ p1 p2) '(2 2 2))) (setq point_list (cons (list p1 p2 midpt) point_list)) (setq i (1+ i)) ) ) ) (setq sp (vlax-3d-point (getpoint "pick a point for table"))) (Setq vgms (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) (setq numrows (+ (length point_list))) (setq numcolumns 4) (setq rowheight 9) (setq colwidth 70) (setq objtable (vla-addtable vgms sp numrows numcolumns rowheight colwidth)) (vla-settext objtable 0 0 "Line details") (vla-settext objtable 1 0 "Sr No.") (vla-settext objtable 1 1 "Start point") (vla-settext objtable 1 2 "End point") (vla-settext objtable 1 3 "Mid point") (vla-setcolumnwidth objtable 0 21) (vla-setalignment objTable acTitleRow acMiddleCenter) (vla-setalignment objTable acHeaderRow acMiddleCenter) (vla-setalignment objTable acDataRow acMiddleCenter) (vla-setrowheight objTable acDataRow 9.0) (setq row 2 x 1) (foreach val point_list (vla-settext objtable row 0 (rtos x 2 0)) (setq val1 (strcat (rtos (car (nth 0 val)) 2 3) "," (rtos (cadr (nth 0 val)) 2 3))) (vla-settext objtable row 1 val1) (setq val2 (strcat (rtos (car (nth 1 val)) 2 3) "," (rtos (cadr (nth 1 val)) 2 3))) (vla-settext objtable row 2 val2) (setq val3 (strcat (rtos (car (nth 2 val)) 2 3) "," (rtos (cadr (nth 2 val)) 2 3))) (vla-settext objtable row 3 val3) (setq row (1+ row) x (1+ x)) ) (princ) )

Perhaps this ? (vl-load-com) (defun c:lines2cell ( / js AcDoc Space nw_style oldim oldlay ins_pt_cell h_t w_c lst_id-seg lst_pt n obj dxf_10 dxf_11 mid_pt nb nw_obj ename_cell n_row n_column) (princ "\nSelect points.") (while (null (setq js (ssget '((0 . "LINE"))))) (princ "\nSelection empty, or is not a lines!") ) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (= 1 (getvar "CVPORT")) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) ) (cond ((null (tblsearch "LAYER" "Table-Lines")) (vla-add (vla-get-layers AcDoc) "Table-Lines") ) ) (cond ((null (tblsearch "STYLE" "Text-Cell")) (setq nw_style (vla-add (vla-get-textstyles AcDoc) "Text-Cell")) (mapcar '(lambda (pr val) (vlax-put nw_style pr val) ) (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag) (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 (/ (* 15.0 pi) 180) 1.0 0.0) ) (command "_.ddunits" (while (not (zerop (getvar "cmdactive"))) (command pause) ) ) ) ) (setq oldim (getvar "dimzin") oldlay (getvar "clayer") ) (setvar "dimzin" 0) (setvar "clayer" "Table-Lines") (initget 9) (setq ins_pt_cell (getpoint "\nLeft-Up insert point of table: ")) (initget 6) (setq h_t (getdist ins_pt_cell (strcat "\nHigth text <" (rtos (getvar "textsize")) ">: "))) (if (null h_t) (setq h_t (getvar "textsize")) (setvar "textsize" h_t)) (initget 7) (setq w_c (getdist ins_pt_cell "\nWidth of cells: ")) (setq lst_id-seg '() lst_pt '() nb 0 ) (repeat (setq n (sslength js)) (setq obj (ssname js (setq n (1- n))) dxf_10 (cdr (assoc 10 (entget obj))) dxf_11 (cdr (assoc 11 (entget obj))) mid_pt (mapcar '* (mapcar '+ dxf_10 dxf_11) '(0.5 0.5 0.5)) lst_pt (cons (list dxf_10 dxf_11 mid_pt) lst_pt) nb (1+ nb) lst_id-seg (cons nb lst_id-seg) ) ) (mapcar '(lambda (p tx) (setq nw_obj (vla-addMtext Space (vlax-3d-point p) 0.0 tx ) ) (mapcar '(lambda (pr val) (vlax-put nw_obj pr val) ) (list 'AttachmentPoint 'Height 'DrawingDirection 'InsertionPoint 'StyleName 'Layer 'Rotation) (list 5 h_t 5 p "Text-Cell" "Table-Lines" 0.0) ) ) (mapcar 'caddr lst_pt) lst_id-seg ) (vla-addTable Space (vlax-3d-point ins_pt_cell) (+ 2 nb) 10 (+ h_t (* h_t 0.25)) w_c) (setq ename_cell (vlax-ename->vla-object (entlast)) n_row (1+ nb) n_column -1) (vla-SetCellValue ename_cell 0 0 (vlax-make-variant (strcat "Summary of " (itoa (sslength js)) " LINES") 8 ) ) (vla-SetCellTextStyle ename_cell 0 0 "Text-Cell") (vla-SetCellTextHeight ename_cell 0 0 (vlax-make-variant h_t 5)) (vla-SetCellAlignment ename_cell 0 0 5) (foreach n (mapcar'list (append lst_id-seg '("N°")) (append (mapcar 'rtos (mapcar 'caar lst_pt)) '("Start X")) (append (mapcar 'rtos (mapcar 'cadar lst_pt)) '("Start Y")) (append (mapcar 'rtos (mapcar 'caddar lst_pt)) '("Start Z")) (append (mapcar 'rtos (mapcar 'caadr lst_pt)) '("End X")) (append (mapcar 'rtos (mapcar 'cadadr lst_pt)) '("End Y")) (append (mapcar 'rtos (mapcar 'caddar (mapcar 'cdr lst_pt))) '("End Z")) (append (mapcar 'rtos (mapcar 'caaddr lst_pt)) '("Middle X")) (append (mapcar 'rtos (mapcar 'cadadr (mapcar 'cdr lst_pt))) '("Middle Y")) (append (mapcar 'rtos (mapcar 'caddar (mapcar 'cddr lst_pt))) '("Middle Z")) ) (mapcar '(lambda (el) (vla-SetCellValue ename_cell n_row (setq n_column (1+ n_column)) (vlax-make-variant el 8)) (vla-SetCellTextStyle ename_cell n_row n_column "Text-Cell") (vla-SetCellTextHeight ename_cell n_row n_column (vlax-make-variant h_t 5)) (if (eq n_row 1) (vla-SetCellAlignment ename_cell n_row n_column 5) (vla-SetCellAlignment ename_cell n_row n_column 6) ) ) n ) (setq n_row (1- n_row) n_column -1) ) (setvar "dimzin" oldim) (setvar "clayer" oldlay) (prin1) )

Not sure why you are asking me about units, you could try making the variable names "Aunits". with double quotes, works in Bricscad, else you can use a foreach loop but I would use car & cadr in the loop, (list (list "aunits" 2)("list 'auprec"4)(......)) Just a suggestion for labelling, the character "A" is (chr 65) (chr x) so you can start with a number and each time you run the section lisp it will add 1 to the x, this will do up to 26. You can save the value of X by using ldata so when dwg is opened again you still have next value and can display that in a prompt. So Enter will give next value. Yes there is code for AA AB etc. Why not a dynamic block then can have a single stretch parameter based on the two pick points.

As Steven P said, your arcs in order to keep the same display or look should be converted to ellipses or splines, because they are in 3d and to be displayed in 2d should be converted because they're not plain sections of circles as an arc in 2d is meant to be, that's why most of the codes don't apply to what you want

I'm sure I did because I tried exploding an object. But it didn't fill. There must be an error somewhere, but I couldn't find it, so I tried another method. Also, I'm a new programmer and I started writing lips without knowing anything about ACAD, so it was extra difficult. I'm glad this forum exists :)))

I found it making a google research is at: https://sites.google.com/site/cadkits/home/chz20 And I don't know if this is of some help

There is a CHZ20.vlx around somewhere, I do not recall everything it does or how fast it would be. What exactly is the time on a basic drawing? As mentioned, cannot really tell any specific issues without the full LISP. I have noticed FLATTEN actually can take a long time on a drawing with lots of objects, even if it is completely z=0 already. FLATTEN and FLATSHOT are mostly useless, IMHO. I would start with just a simple z=0 LISP, then run different LISPs to specifically target other objects like Regions and Blocks. I am not sure if the arc issue have ever been solved, you may have to look around and see. Can you post a sample drawing?

That's strange, in my testing it works as I expected. Are you able to post a sample drawing with an arc that rotates? Going to look at the other object types sometime today for you. There is a list at the top of 'Flatten Lines' that work at the moment for info.

Hi, Here is a code that projected simples entities : POLYLINE,LWPOLYLINE,LINE,SPLINE,ARC,CIRCLE,ELLIPSE,POINT. on the SCG at a Z-coordinate to zero if as the entities of start are in a UCS parallel or not. For example, a circle in a UCS non-parallel will become an ellipse. I do this because this is much faster than FLATTEN (which is more efficient: it can handle more entities, but slow) If it can help... (defun l-coor2l-pt (lst flag / ) (if lst (cons (list (car lst) (cadr lst) (if flag (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst)) (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) ) ) (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag) ) ) ) (vl-load-com) (defun c:my_project ( / jspl nbr n AcDoc Space UCS save_ucs WCS ent_name indx l_blg l_pt ename id_obj pl_typ index nw_pl) (setq jspl (ssget '((-4 . "<OR") (-4 . "<AND") (0 . "POLYLINE") (-4 . "<NOT") (-4 . "&") (70 . 112) (-4 . "NOT>") (-4 . "AND>") (0 . "LWPOLYLINE,LINE,SPLINE,ARC,CIRCLE,ELLIPSE,POINT") (-4 . "OR>")) ) nbr -1 n 0 ) (cond (jspl (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (eq (getvar "CVPORT") 1) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) UCS (vla-get-UserCoordinateSystems AcDoc) save_ucs (vla-add UCS (vlax-3d-point '(0.0 0.0 0.0)) (vlax-3d-point (getvar "UCSXDIR")) (vlax-3d-point (getvar "UCSYDIR")) "CURRENT_UCS" ) ) (vla-put-Origin save_ucs (vlax-3d-point (getvar "UCSORG"))) (vla-StartUndoMark AcDoc) (setq WCS (vla-add UCS (vlax-3d-Point '(0.0 0.0 0.0)) (vlax-3d-Point '(1.0 0.0 0.0)) (vlax-3d-Point '(0.0 1.0 0.0)) "TEMP_WCS")) (vla-put-activeUCS AcDoc WCS) (repeat (sslength jspl) (setq ent_name (ssname jspl (setq nbr (1+ nbr))) indx -1 l_blg nil l_pt nil ename (vlax-ename->vla-object ent_name) id_obj (vla-get-ObjectName ename) ) (cond ((member id_obj '("AcDbPolyline" "AcDb2dPolyline" "AcDb3dPolyline")) (setq pl_typ (if (vlax-property-available-p ename 'Type) (vlax-get ename 'Type))) (if (member id_obj '("AcDbPolyline" "AcDb2dPolyline")) (if (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13)) (progn (repeat (fix (vlax-curve-getEndParam ename)) (setq l_pt (cons (vlax-curve-GetPointAtParam ename (setq indx (1+ indx))) l_pt) index (float indx)) (if (or (eq pl_typ 1) (if (< pl_typ 3) (not (zerop (vla-GetBulge ename indx))))) (while (eq indx (fix (+ 0.01 index))) (setq l_pt (cons (vlax-curve-GetPointAtParam ename (setq index (+ 0.01 index))) l_pt)) ) ) ) (setq l_pt (cons (vlax-curve-getEndPoint ename) l_pt)) ) (setq l_pt (mapcar '(lambda (x) (trans (list (car x) (cadr x) (- ;+ (if (eq id_obj "AcDbPolyline") (caddr x) 0.0) (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) ) ) ent_name 0 ) ) (l-coor2l-pt (vlax-get ename 'Coordinates) (eq id_obj "AcDb2dPolyline")) ) ) ) (setq l_pt (l-coor2l-pt (vlax-get ename 'Coordinates) T)) ) (if (eq (vla-get-ObjectName ename) "AcDbPolyline") (setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt))))) (setq nw_pl (vlax-invoke Space 'AddPolyline (apply 'append l_pt))) ) (vla-put-Normal nw_pl (vlax-3d-point '(0 0 1))) (if (vlax-property-available-p ename 'Type) (progn (setq pl_typ (if (eq (vla-get-ObjectName ename) "AcDb3dPolyline") (if (zerop (vlax-get ename 'Type)) (vlax-get ename 'Type) (1+ (vlax-get ename 'Type))) (vlax-get ename 'Type) ) ) (if (and (vlax-property-available-p ename 'Normal) (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13)) (eq pl_typ 1)) (vla-put-Type nw_pl 0) (vla-put-Type nw_pl pl_typ) ) ) (if (and (vlax-property-available-p ename 'Normal) (equal (vlax-get ename 'Normal) '(0 0 1) 1E-13)) (progn (repeat (length l_pt) (setq l_blg (cons (vla-GetBulge ename (setq indx (1+ indx))) l_blg))) (foreach el l_blg (vla-SetBulge nw_pl indx el) (setq indx (1- indx))) ) ) ) (vla-put-Closed nw_pl (vlax-get ename 'Closed)) ) ((member id_obj '("AcDbEllipse" "AcDbCircle" "AcDbArc")) (if (not (equal (vlax-get ename 'Normal) '(0.0 0.0 1.0) 1E-13)) (progn (setq index (vlax-curve-getStartParam ename) l_pt (list (vlax-curve-GetPointAtParam ename index)) ) (while (< (setq index (+ 0.01 index)) (vlax-curve-getEndParam ename)) (setq l_pt (cons (vlax-curve-GetPointAtParam ename index) l_pt)) ) (setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt))))) ) (cond ((eq id_obj "AcDbEllipse") (setq l_pt (vlax-get ename 'Center) nw_pl (vlax-invoke Space 'AddEllipse (list (car l_pt) (cadr l_pt) 0.0) (list (car (vlax-get ename 'MajorAxis)) (cadr (vlax-get ename 'MajorAxis)) 0.0) (* (caddr (vlax-get ename 'Normal)) (vlax-get ename 'RadiusRatio)) ) ) (vla-put-Normal nw_pl (vlax-3d-point '(0 0 1))) (vla-put-StartAngle nw_pl (vlax-get ename 'StartAngle)) (vla-put-StartParameter nw_pl (vlax-get ename 'StartParameter)) (vla-put-EndParameter nw_pl (vlax-get ename 'EndParameter)) ) ((or (eq id_obj "AcDbArc") (eq id_obj "AcDbCircle")) (setq l_pt (vlax-get ename 'Center) nw_pl (if (eq id_obj "AcDbArc") (vlax-invoke Space 'AddArc (list (car l_pt) (cadr l_pt) 0.0) (vlax-get ename 'Radius) (vlax-get ename 'StartAngle) (vlax-get ename 'EndAngle)) (vlax-invoke Space 'AddCircle (list (car l_pt) (cadr l_pt) 0.0) (vlax-get ename 'Radius)) ) ) (vla-put-Normal nw_pl (vlax-3d-point '(0 0 1))) ) ) ) ) ((eq id_obj "AcDbSpline") (if (or (zerop (vlax-get ename 'IsPlanar)) (and (not (zerop (vlax-get ename 'IsPlanar))) (not (equal (cdr (assoc 210 (entget ent_name))) '(0.0 0.0 1.0) 1E-13)) ) ) (progn (setq index (vlax-curve-getStartParam ename) l_pt (list (vlax-curve-GetPointAtParam ename index)) ) (while (< (setq index (+ 10.0 index)) (vlax-curve-getEndParam ename)) (setq l_pt (cons (vlax-curve-GetPointAtParam ename index) l_pt)) ) (setq nw_pl (vlax-invoke Space 'AddLightWeightPolyline (apply 'append (mapcar 'list (mapcar 'car l_pt) (mapcar 'cadr l_pt))))) ) (progn (setq l_pt (l-coor2l-pt (if (zerop (vlax-get ename 'NumberOfFitPoints)) (cdddr (reverse (cdddr (reverse (vlax-get ename 'ControlPoints))))) (vlax-get ename 'FitPoints)) T) nw_pl (vlax-invoke Space 'AddSpline (apply 'append (mapcar '(lambda (x y) (list x y 0.0)) (mapcar 'car l_pt) (mapcar 'cadr l_pt))) (list (car (vlax-curve-getFirstDeriv ename 0)) (cadr (vlax-curve-getFirstDeriv ename 0)) 0.0) (list (car (vlax-curve-getFirstDeriv ename (vlax-curve-getEndParam ename))) (cadr (vlax-curve-getFirstDeriv ename (vlax-curve-getEndParam ename))) 0.0) ) l_pt (l-coor2l-pt (vlax-get ename 'ControlPoints) T) ) (vla-put-ControlPoints nw_pl (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (* (length l_pt) 3))) ) (apply 'append (mapcar '(lambda (x y) (list x y 0.0)) (mapcar 'car l_pt) (mapcar 'cadr l_pt))) ) ) ) ) ) ) ((eq id_obj "AcDbLine") (setq nw_pl (vlax-invoke Space 'AddLine (list (car (vlax-get ename 'StartPoint)) (cadr (vlax-get ename 'StartPoint)) 0.0) (list (car (vlax-get ename 'EndPoint)) (cadr (vlax-get ename 'EndPoint)) 0.0) ) ) (vla-put-Normal nw_pl (vlax-3d-point '(0 0 1))) ) ((eq id_obj "AcDbPoint") (setq nw_pl (vlax-invoke Space 'AddPoint (list (car (vlax-get ename 'Coordinates)) (cadr (vlax-get ename 'Coordinates)) 0.0) ) ) (vla-put-Normal nw_pl (vlax-3d-point '(0 0 1))) ) ) (vla-put-TrueColor nw_pl (vla-get-TrueColor ename)) (vla-put-LineType nw_pl (vla-get-LineType ename)) (vla-put-LinetypeScale nw_pl (vla-get-LinetypeScale ename)) (vla-put-Lineweight nw_pl (vla-get-Lineweight ename)) (vla-put-Material nw_pl (vla-get-Material ename)) (vla-put-Layer nw_pl (vla-get-Layer ename)) (vla-delete ename) ) (and save_ucs (vla-put-activeUCS AcDoc save_ucs)) (and WCS (vla-delete WCS) (setq WCS nil)) (vla-EndUndoMark AcDoc) (princ (strcat "\n" (itoa (sslength jspl)) " entity(s) submissive to the command. ENDED !" ) ) ) (T (princ "\nNo compliant entities selected..!")) ) (prin1) )

Thanks MHUPP - that was a thought I'd add for the OP tomorrow, can copy and paste from here rather than try to remember where I last used last ent.

if you want a radio button pick have a look at my Multi radio buttons.lsp it can hold about 20 values vertically. once you pick I use Ldata to save the value in a dwg, in the multi R you can set the button to the current value. In a pop menu would be just a load a lisp as normal all the values being in it that lisp.

Hi @CivilTechSource, Here is the an example how you can do it on different approach. In AutoCAD exist "blackboard", where you can store the desired value where you can than use that value in the other open drawings (more about blackboard: About Sharing Data Between Namespaces (AutoLISP)). In this example, I have a "text size values.txt" file with different heights. It can be update with other height values. 1.0 1.5 2.0 2.5 3.0 3.5 4.0 4.5 5.0 5.5 6.0 6.5 7.0 7.5 8.0 8.5 9.0 9.5 10.0 So, after run this function, you will first choose the file with values (in this case "text size values.txt"), than pick the desired value and add it to blackboard. (prompt "\nCall function: (getValueFromListBlackboard)") (princ) ;; Add any value from list to the "blackboard" (defun getValueFromListBlackboard ( / *dcl_id* *file_name* *op* *lst* *textSize* *path* *file* *line* *rval*) (setq *path* (getfiled "Open the txt file with list of values"" "txt" 0) *file* (open *path* "r") ) (if *file* (progn (while (setq *line* (read-line *file*)) (setq *lst* (append *lst* (list *line*))) ) (close *file*) ) ) (setq *file_name* (vl-filename-mktemp "textHeight.dcl") *op* (open *file_name* "w") ) (write-line "textHeight :dialog { label = \"Select Text Heights\"; :list_box { key = \"tx\"; multiple_select = true; height = 20; width = 30; } :row { :button { label = \"Pick text height\"; key = \"bth\"; fixed_width = true; } :button { label = \"Cancel\"; key = \"cancel\"; mnemonic = \"C\"; alignment = centered; fixed_width = true; is_cancel=true; } } }" *op*) (close *op*) (setq *dcl_id* (load_dialog *file_name*)) (if (not (new_dialog "textHeight" *dcl_id*)) (exit) ) (action_tile "cancel" "(done_dialog 0)") (start_list "tx") (mapcar 'add_list *lst*) (end_list) (defun return_value () (setq *rval* (nth (atoi (get_tile "tx")) *lst*)) ) (action_tile "bth" "(return_value) (done_dialog 1)") (start_dialog) (unload_dialog *dcl_id*) (vl-file-delete *file_name*) (vl-bb-set '*textSize* *rval*) (vl-bb-ref '*textSize*) ) After you pick the desire height, you can change it in all open drawings for any text. In this case, I made a little lisp for that and I need it to call every time in different drawing (except if you don't want to make it in support file search path or to be autoloaded every time when AutoCAD is started). (defun c:CTH ( / data) (setq data (entget (car (entsel "\nSelect the text:")))) (entmod (subst (cons 40 (atof (vl-bb-ref '*textSize*))) (assoc 40 data) data)) ) An example video of how it works you can see below. ChangeTextWithValueFromBlackboard.mp4 Maybe in this you can get some idea how to make it work in your case. Also, you can add "getValueFromListBlackboard" to CUI and make it easier to call. Best regards.

If you would run through -OVERKILL you can see current settings and the options in the command line, just add what you need to the line in the LISP, just getting the selection and ENTER twice is going to default to last used settings. Command: -OVERKILL Select objects: all 1935 found 426 were not in current space. Select objects: Current settings: Tolerance=1.000000, Ignore=All, Optimize polylines=Yes, Combine partial overlap=Yes, Combine end-to-end=Yes Enter an option to change [Done/Ignore/tOlerance/optimize Plines/combine parTial overlap/combine Endtoend/Associativity] <done>: *Cancel* The Uppercase letters are the shortcut, i.e. for Tolerance use O (value), optimize Plines use P, etc. You might find something on this thread... I need overkill and ncopy !please help me! - AutoLISP, Visual LISP & DCL - AutoCAD Forums

With ARX, you can use Brep or AssocPersSubentIdPE, the later is a bit simpler to use. AssocPersSubentIdPE will get you the faces, edges, and vertices of the solid. In the case of a cuboid, simply get all the edges and map them to a vertex In this example each vertex should be mapped to three edges. You could then build a transformation matrix so you can accurately compute the dimensions. It starts to get a lot harder with more complex shapes. There’s a few threads at the swamp discussing ideas how to work with I-beams, how to find the edge the run along the length for reference import traceback from pyrx import Ap, Ax, Ge, Ed, Db, command from collections import defaultdict @command def doit(): ps, id, pnt = Ed.Editor.entSel("\nPick it: \n", Db.Solid3d.desc()) solid = Db.Solid3d(id) pe = Db.AssocPersSubentIdPE(solid.queryX(Db.AssocPersSubentIdPE.desc())) edge_map = defaultdict(list[Ge.Curve3d]) for vrt in pe.getAllSubentities(solid, Db.SubentType.kVertexSubentType): edge_map[pe.getVertexSubentityGeometry(solid, vrt)] for edge in pe.getAllSubentities(solid, Db.SubentType.kEdgeSubentType): crv = pe.getEdgeSubentityGeometry(solid, edge) edge_map[crv.getStartPoint()].append(crv) edge_map[crv.getEndPoint()].append(crv) for k, v in edge_map.items(): for _crv in v: Ed.Core.grDraw(_crv.getStartPoint(), _crv.getEndPoint(), 1, 0) return

Just a out there way to get centroid, if you have a open pline then close it, use "Extrude" a height of say 10, then use "Massprop". Centroid: X= 0.388 Y= -3.101 Z= 5 Ok so choose the write to file option and read the centroid from the file, the sixth line. If you want the pline open then do a UNDO. Yes it will be a lisp, have used the write to file for concrete Tilt panels to mark the centroid.

A viewport has a custom scale you can see it when you click on it and using Property. So rescale the viewport then change the custom scale value to suit. Play with some standard scales and look at what Custom scale value is, metric makes it easy. You may also want to pick a point in model space (setq pt (getpoint "\nPick ")) once you have this you can use Zoom C pt scale, this will re center your view, then set your custom scale. A ps Zoom valueXP eg Zoom 0.25XP, sets the scale also. Lastly it's always a good idea to lock a viewport so you don't accidently zoom inside it.

How about this. Draw a polyline around the border of the viewport. Use the CHSPACE command to move it from paper space (the key viewport) to model space. You now have a visual guide for aligning the viewport with the area you want to show. When you're done, erase the guide.

With AutoCAD LT not running, open Windows REGEDIT and navigate to: HKEY_CURRENT_USER\Software\Autodesk\AutoCAD\Rxx.x\ACAD-xxxx:xxx\Profiles\**your profile name**\Drawing Recovery (items in blue may vary) Then look in the subfolder named "Unresolved", you should find the file names of these files. I deleted all entries in this folder and fired up AutoCAD and the DrawingRecovery list is empty.

Have a play with this (defun c:foo ( / s e ) (princ "\n Pick on one line to get its length :") (if (setq s (ssget "_+.:S:E" '((0 . "LINE")))) (princ (strcat "\n Total Length is : " (rtos (distance (cdr (assoc 10 (setq e (entget (ssname s 0))))) (cdr (assoc 11 e))) 2))) ) (princ) )