Just a funny / basic toolbar

2025-07-08T14:03:48Z

I wanted more buttons but ran out of space so just created an alternative reallity for myself.

It's very basic / simple and still a work in progress but as usual time is not on my side especially now my boss in away for 4 weeks and he probably was afraid I would get bored and start to play with myself so he left me with a load of work.

Update : because this routine uses grread you can't run any other (transparent) commands.

Thats why I added 'hot' keys for zoom. E for extents, Z for zoom , + & - for zooming in & out.

Maybe it's useful , maybe it's not...bite me.

;;; RlxGrMenu - 2025-07-09 - Just a funny / very basic little 'toolbar'
;;; It draws a column with 12 rows. Config is not working yet, quit by click or by typing Q or q.
;;; I've run a little out of button-space so wanted an out of the box solution to this problem.
;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less.
;;; Substitute the names in app-list (setq app-list '("LC" "VT" ...) with names from your own favorite apps
;;; apps have to be in search path so (findfile (strcat "MyApp" ".lsp") should work'.
;;; Also app should not be self executing and the start command should be same as app name
;;; If your app is named "MyApp" this routine loads app if found and starts it with (eval (read (strcat "C:" "Myapp")))
;;; have fun

;;; ------------------------------ ;;;
;;; |S1                        S2| ;;;
;;; |   -------------- -----  [a]| ;;;
;;; |   |E1              E2|  [b]| ;;;
;;; |   |                  |  [c]| ;;;
;;; |   |                  |  [d]| ;;;
;;; |   |E3              E4|  [e]| ;;;
;;; |   --------------------  [f]| ;;;
;;; |S3                        S4| ;;;
;;; ------------------------------ ;;;
;;; (count_calcula) :
;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4
;;; screen corner points  : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-)
;;; extents corner points : E1 - E5  extmin / extmax
;;; viewsize             : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize)

;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685)
;;; - 12 rows, 1-10 for user , 11 for confid , 12 for exit
;;; - height each row = (fix (/ (- y+ y-) 12)) , for example 25
;;; - row width = row height , lets call it cell-size

;;; cell-ip = (list (- (fix x+) cell-size) (fix y+))
;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90

(defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x app-list app gr-loop
                     tblc tbtc)
  (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit"))
  (setq gr-loop T tblc 7 tbtc 7) ;;; toolbar line color / toolbar text colot
  (redraw_menu)
  ;;; launch app
  (if app (RlxGrMenu_Start_App app))
)

(defun redraw_menu ()
  (redraw)
  ;;; get live screen data
  (count_calcula)
  ;(setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit"))
  ;(setq cell-h (fix (/ (- y+ y-) 12)) cell-w (* cell-h 2))
  ;;;; corner points
  ;(setq cell-ul (list (- (fix x+) cell-w) (fix y+)) cell-ur (list (fix x+) (fix y+))
  ;      cell-ll (list (- (fix x+) cell-w) (fix y-)) cell-lr (list (fix x+) (fix y-)))

  (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2))
  ;;; corner points
  (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+)
        cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-))
  
  ;;; draw the outlines
  (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc)
  ;;; get y values for all horizontal separators
  (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h))
  (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc))
  ;;; label the cell
  (setq ctr-x (+ (car cell-ll) (* cell-w 0.5)))
  (mapcar '(lambda (s y)
             (grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M"))
                 app-list (append y-list (list (- (last y-list) cell-h))))
  (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list))
  (princ)
)

;;; (re) calculate display parameters (count_calcula)
(defun count_calcula ()
  (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5)
	x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr")
	vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0)))
;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-))

(defun screen_res (/ s i is)
  (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil)
    is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController"))
      (vlax-for i is (vlax-get i 'CurrentHorizontalResolution)))

;;; get aspect ratio current screen
(defun asp_rat () (rtos (* 1.5 (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE"))))))


;;; determine status caps lock for when typing filter (even though filter uses strcase)
(defun case (s) (cond ((null s) "") ((not (eq (type s) 'STR)) "")
  ((null capslock) s) (t (if (= (acet-sys-keystate 20) 0) (strcase s t) (strcase s)))))

;;; 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)
(defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l))


;;; 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 justificationz
;;; *** UPPER CASE ONLY ***  (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M")
(defun grtxt (ts cp cl a j / vp ltb i xp z 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
  (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2))

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


;;; probably won't need tracking mode (cut-copy-paste you know...)
(defun RlxGrMenu_Get_Cell_ID  (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id
                                       prev-view-size cur-view-size rtn)
  (princ "\rEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -")

  (setq prev-view-size (getvar "viewsize"))
  (while gr-loop
    (setq cur-view-size (getvar "viewsize"))
    (setq inp (vl-catch-all-apply 'grread (list T 8 1)))
    (if (vl-catch-all-error-p inp)
      (progn (setq gr-loop nil inp nil)(redraw))
      (progn
        (setq dev (car inp) tpt (cadr inp))
        (cond
          ;;; space , q or Q (Quit)
          ((and (= dev 2) (member (last inp) '(32 113 81)))
           (redraw)(setq gr-loop nil)
          )
          ;;; point selection (3 (221.882 173.853 0.0))
          ((= dev 3)
           (if (setq rtn (find_cell tpt xl yl))
             (progn
               ;(alert (setq app (nth (1- (atoi rtn)) app-list)))
               (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list))))
               (setq gr-loop nil)
             )
            )
          )
          ;;; device tracking point (probably don't need tracking mode)
          ((= dev 5)
           ;;; if mouse moved
           (if (or (/= (car  prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt)))
             (progn (setq prev-tpt tpt )))
           (if (not (equal cur-view-size prev-view-size))
             (progn
               (setq prev-view-size cur-view-size)
               (redraw_menu)
             )
           )
          )
          ; user pressed E of e
          ((member inp '((2 69)(2 101))) (command "zoom" "e"))
          ; user clicked R-mouse button, pressed enter or space (done selecting)
          ((or (equal (car inp) 25)(member inp '((2 13)(2 32))))
           (redraw)(setq gr-loop nil app "Quit"))
          ; user pressed +
          ((equal inp '(2 43)) (vl-cmdf "zoom" "2x"))
          ; user pressed -
          ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x"))
          ; user pressed z or Z
          ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" ""))

        )
      )
    )
  )
  (princ)
)

;;; pt = point , xl = x-list , yl = y-list
;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1)
(defun find_cell ( pt xl yl / ptx pty y-lst l n hit)
  (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>))
  (if (< (car xl) ptx (cadr xl))
    (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list))
  (if n (itoa (1+ n)))
)

;;; program assumes no self starting routines and start command is "C:" + app name
(defun RlxGrMenu_Start_App (app / fn)
  (cond
    ((setq fn (findfile (strcat app ".lsp")))
     (redraw)(load fn)(eval (read (strcat "(C:" app ")"))))
    ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw))
    ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw))
    (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye")))
  )
  (princ)
)

;;; future...

;;; RlxGrMenu - Rlx Jul/25
(defun RlxGrMenu_future
       ( /
        ;;; global variables
        scr-res cell-rows cell-cols cell-col cell-id app-list
        ;;; display parameters like viewctr/viewsize/screensize (count_calcula)
        vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h
        ;;; registry variables
        RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols
        RlxGrMenu-app-list
       )
  ;;; mostly not used because for now I just just one column with 10 rows
  (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1)
  (count_calcula)
  (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare"))
  (RlxGrMenu_Init)
  (RlxGrMenu_Doit)
  (RlxGrMenu_Exit)
  (princ)
)

(defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init "))
(defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit "))
(defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit "))


(defun c:RlxGrMenu ()(draw_menu))
(defun c:t1 ()(draw_menu))
(defun t1 ()(draw_menu))

Edited 16 hours ago by rlx
added zoom and a few tweaks

2025-07-08T22:33:16Z

Amazing and original.
I find it interesting to see how you’ve solved the character's drawing using polar coordinates.
I also did something similar when I was thinking about drawing text next to the cursor in real time. I even created tools to encode characters from drawing polylines. But I gave up on the idea because there are simpler options.

However, your approach is a different one — something I had never considered.
It’s an interesting idea that opens the door to imagining new possibilities

Edited yesterday at 10:35 PM by GLAVCVS

2025-07-08T22:44:56Z

to be honest, the grtext part its something I found a long time ago (grtxt.lsp , but can't find the site it came from anymore , nor does it have information about the author) It's not as good as Lee's grtext (this one only does uppercase) but it's simpler and gets the job done.

Edited 7 hours ago by rlx

2025-07-08T23:34:42Z

Wish i still had cad to test this out.

2025-07-09T06:37:11Z

7 hours ago, mhupp said:

Wish i still had cad to test this out.

Oh , you're not lisping anymore? pitty... you belong to the top lispy's

2025-07-09T07:26:00Z

12 hours ago, rlx said:

to be honest, its something I found a long time ago but could not find the author but maybe I still have the link somewhere and will include it if I do. It's not as good as Lee's grtext but it's simpler and gets the job done.

Have you considered replacing grvecs with temporary 'TEXT' objects?
It's easier to do this with dynamically sized and positioned text.

This makes it easier to create effects such as mouse-over highlighting.

@mhupp "It's never too late to return to the old places where you loved life"

Edited 12 hours ago by GLAVCVS

2025-07-09T08:26:58Z

Nice, I can see uses for this. Might add a slight change one day if it works to draw a wipeout under the 'buttons'?

2025-07-09T10:51:12Z

Interesting for sure!

2025-07-09T11:12:26Z

3 hours ago, GLAVCVS said:

Have you considered replacing grvecs with temporary 'TEXT' objects?
It's easier to do this with dynamically sized and positioned text.

This makes it easier to create effects such as mouse-over highlighting.

@mhupp "It's never too late to return to the old places where you loved life"

have done a sort of messenger in the past with (m)text so just wanted to try something else. With vectors a simple redraw and your plate is clean again. I was / am considering adding background but for now wanted to keep it fast & furious due to workload (turning my boss's promises into reality)

2025-07-09T21:42:12Z

did a little cleaning & tweaking and added a (grdraw) background to give it just a tiny bit more spunk ... enjoy

;;; RlxGrMenu - 2025-07-09 - Just a funny / basic / tiny 'toolbar'
;;; It draws a column on the right of your screen with 12 rows.
;;; Config is not working yet and I'm not sure it's worth the effort because its only meant as a lisp launcher.

;;; Quit by click on QUIT in toolbar or by typing Q , q or space, zoom in / out with +/-/z
;;; I've run a little out of button-space so wanted an out of the box solution to this problem.
;;; this is just a way to run my 10 most used lisp routines, nothing more , nothing less.
;;; Substitute the names in app-list (setq app-list (list "LC" "VT"...) with names from your own favorite apps
;;; Apps (lisps) have to be in search path so (findfile (strcat "MyApp" ".lsp") should work.
;;; Also apps should not be self executing and the start command should be same as app name.
;;; If your app is named "MyApp" this routine loads the app if found and starts it with (eval (read (strcat "C:" "Myapp")))
;;; have fun
;;; ------------------------------ ;;;
;;; |S1                        S2| ;;;
;;; |   -------------- -----  [a]| ;;;
;;; |   |E1              E2|  [b]| ;;;
;;; |   |                  |  [c]| ;;;
;;; |   |                  |  [d]| ;;;
;;; |   |E3              E4|  [e]| ;;;
;;; |   --------------------  [f]| ;;;
;;; |S3                        S4| ;;;
;;; ------------------------------ ;;;
;;; (count_calcula) : run time values for viewsize / viewcenter etc
;;; values are effected by resize window : vc , vs , ss , x+ , x- , y+ , y- , P1-P4
;;; screen corner points  : S1 = (x- y+) , S2 (x+ y+) , S3 (x- y-) , S4 (x+ y-)
;;; extents corner points : E1 - E5  extmin / extmax
;;; viewsize              : vs - height current viewport (drawing units) (i.e. 300 / 386 after resize)

;;; screen size : ss (1187 532) (pixels) after max acad window : vs = 386 , ss = (1840 685)
;;; - 12 rows, 1-10 for user , 11 for config , 12 for exit
;;; - height each row = viewsize / 12, row width = 2 x row height

;;; cell-ip = (list (- (fix x+) cell-size) (fix y+))
;;; vector draw cell-ip -> cell-size<0, (* cell-size 12)<270 , cell-size<180 , (* cell-size 12)<90

(defun draw_menu ( / ip-x ip-y cell-h cell-w cell-ul cell-ll cell-ur cell-lr y-list ctr-x
                     app-list app gr-loop tblc tbtc tbbc start-viewsize)
  (setq app-list
    (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare" "Config" "Quit"))
  ;;; toolbar line color / toolbar text color / toolbar background color
  (setq gr-loop T tblc 7 tbtc 7 tbbc 8)
  ;;; when zooming in/out it messes up back ground fill so have to compensate for that
  (setq start-viewsize (getvar "viewsize"))
  (redraw_menu)
  ;;; launch app
  (if app (RlxGrMenu_Start_App app))
)

(defun redraw_menu ()
  (redraw)
  ;;; get live screen data
  (count_calcula)
  (setq cell-h (/ (- y+ y-) 12) cell-w (* cell-h 2))
  ;;; corner points
  (setq cell-ul (list (- x+ cell-w) y+) cell-ur (list x+ y+)
        cell-ll (list (- x+ cell-w) y-) cell-lr (list x+ y-))
  
  
  ;;; get y values for all horizontal separators
  (setq x-list (list (car cell-ll) (car cell-lr)) y-list (gnl- (- (fix y+) cell-h) 11 cell-h))
  ;;; fill the backgrounds
  (setq yy y-)
  (while (< yy y+)
    (grdraw (list (car cell-ll) yy) (list (car cell-lr) yy) tbbc)
    ;;; next y depends on zoom factor (viewsize) , 0.25 is emperical, bigger means bigger linespacing
    (setq yy (+ yy (* 0.25 (/ (getvar "viewsize") start-viewsize))))
  )
  ;;; draw the outlines
  (grdraw cell-ll cell-ul tblc)(grdraw cell-ul cell-ur tblc)(grdraw cell-ur cell-lr tblc)(grdraw cell-lr cell-ll tblc)
  ;;; drawn separators
  (foreach y y-list (grdraw (list (car cell-ll) y) (list (car cell-lr) y) tblc))
  ;;; label the cell
  (setq ctr-x (+ (car cell-ll) (* cell-w 0.5)))
  (mapcar '(lambda (s y)(grtxt (strcase s) (list ctr-x (+ y (* cell-h 0.5))) tbtc 0 "M"))
            app-list (append y-list (list (- (last y-list) cell-h))))
  (if gr-loop (RlxGrMenu_Get_Cell_ID x-list y-list))
)

;;; fill cell with cell background color , use offset of 0.5 unit so outlines remain visible
(defun fill_cell (x y w h / x2 y2 w2 h2 x3)
  (setq x2 (+ x 0.5) y2 (+ y 0.5) w2 (- w 1) h2 (- h 1) x3 (+ x2 w2))
  ;(repeat (* (fix h2) 2) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5)))
  (while (< y2 (cadr cell-ul)) (grdraw (list x2 y2) (list x3 y2) tbbc)(setq y2 (+ y2 0.5)))
)

;;; (re) calculate display parameters (count_calcula)
(defun count_calcula ()
  (setq vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE") dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5)
	x- (- (car vc) dx) y- (- (cadr vc) dy) x+ (+ (car vc) dx) y+ (+ (cadr vc) dy) ip (getvar "viewctr")
	vc-x (car ip) vc-y (cadr ip) txt-h (/ (getvar "VIEWSIZE") 100.0)))
;;; (getvar "extmin") (getvar "extmax") (setq dvx (- x+ x-) dvy (- y+ y-))

(defun screen_res (/ s i is)
  (setq s (vlax-invoke (vlax-create-object "WbemScripting.SWbemLocator") 'ConnectServer nil nil nil nil nil nil nil)
    is (vlax-invoke s 'ExecQuery "SELECT CurrentHorizontalResolution, CurrentVerticalResolution FROM Win32_VideoController"))
      (vlax-for i is (vlax-get i 'CurrentHorizontalResolution)))

;;; 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)
(defun gnl- (i n d / l) (setq l (list i))(repeat (1- n)(setq l (cons (setq i (- i d)) l)))(reverse l))

;;; 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 justificationz
;;; *** UPPER CASE ONLY ***  (grtxt (STRCASE "Rob") (getvar "viewctr") 1 0 "M")
(defun grtxt (ts cp cl a j / vp ltb i xp z 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
  (setq z (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")) 0.2))

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


;;; probably won't need tracking mode (cut-copy-paste you know...)
(defun RlxGrMenu_Get_Cell_ID  (xl yl / inp dev tpt prev-tpt mark-current-tracking-point cell-id prev-cell-id
                                       prev-view-size cur-view-size rtn)
  (princ "\nEsc/Q/Rmouse to cancel, zoom with E(extend), Z(oom) or + / -")

  (setq prev-view-size (getvar "viewsize"))
  (while gr-loop
    (setq cur-view-size (getvar "viewsize"))
    (setq inp (vl-catch-all-apply 'grread (list T 8 1)))
    (if (vl-catch-all-error-p inp)
      (progn (setq gr-loop nil inp nil)(redraw))
      (progn
        (setq dev (car inp) tpt (cadr inp))
        (cond
          ;;; space , q or Q (Quit)
          ((and (= dev 2) (member (last inp) '(32 113 81)))
           (redraw)(setq gr-loop nil)
          )
          ;;; point selection (3 (221.882 173.853 0.0))
          ((= dev 3)
           (if (setq rtn (find_cell tpt xl yl))
             (progn
               ;(alert (setq app (nth (1- (atoi rtn)) app-list)))
               (princ (strcat "\nLaunching : " (setq app (nth (1- (atoi rtn)) app-list))))
               (setq gr-loop nil)
             )
            )
          )
          ;;; device tracking point (probably don't need tracking mode)
          ((= dev 5)
           ;;; if mouse moved
           (if (or (/= (car  prev-tpt)(car tpt)) (/= (cadr prev-tpt)(cadr tpt)))
             (progn (setq prev-tpt tpt )))
           (if (not (equal cur-view-size prev-view-size))
             (progn
               (setq prev-view-size cur-view-size)
               (redraw_menu)
             )
           )
          )
          ; user pressed E of e
          ((member inp '((2 69)(2 101))) (command "zoom" "e"))
          ; user clicked R-mouse button, pressed enter or space (done selecting)
          ((or (equal (car inp) 25)(member inp '((2 13)(2 32))))
           (setq gr-loop nil))
          ; user pressed +
          ((equal inp '(2 43)) (vl-cmdf "zoom" "2x"))
          ; user pressed -
          ((equal inp '(2 45)) (vl-cmdf "zoom" ".5x"))
          ; user pressed z or Z
          ((member inp '((2 122)(2 90))) (vl-cmdf "'zoom" ""))

        )
      )
    )
  )
  (princ)
)

;;; pt = point , xl = x-list , yl = y-list
;;; scribble : (< 1 2 3) , (> 3 2 1) , (cdr (vl-sort '(1 2 3 4 5) '>)) -> '(4 3 2 1)
(defun find_cell ( pt xl yl / ptx pty y-lst l n hit)
  (setq n nil hit nil ptx (car pt) pty (cadr pt) y-list (vl-sort (append yl (list 0)) '>))
  (if (< (car xl) ptx (cadr xl))
    (mapcar '(lambda (y)(if (and (not hit) (> pty y)) (setq hit T n (vl-position y y-list)))) y-list))
  (if n (itoa (1+ n)))
)

;;; program assumes no self starting routines and start command is "C:" + app name
(defun RlxGrMenu_Start_App (app / fn)
  (cond
    ((setq fn (findfile (strcat app ".lsp")))
     (redraw)(load fn)(eval (read (strcat "(C:" app ")"))))
    ((wcmatch (strcase app) "QUIT")(princ "\nBye bye")(redraw))
    ((wcmatch (strcase app) "CONFIG")(princ "\nUnder construction")(redraw))
    (t (redraw)(princ (strcat "\nUnable to load " (vl-princ-to-string app) " ...bye")))
  )
)

;;; future...

;;; RlxGrMenu - Rlx Jul/25
(defun RlxGrMenu_future
       ( /
        ;;; global variables
        scr-res cell-rows cell-cols cell-col cell-id app-list
        ;;; display parameters like viewctr/viewsize/screensize (count_calcula)
        vc vs ss dx dy x- x+ y- y+ ip vc-x vc-y txt-h
        ;;; registry variables
        RlxGrMenu-nof-cell-rows RlxGrMenu-nof-cell-cols
        RlxGrMenu-app-list
       )
  ;;; mostly not used because for now I just just one column with 10 rows
  (setq scr-res (screen_res) rows 3 cols 3 cell-col 141 cell-id 1)
  (count_calcula)
  (setq app-list (list "LC" "VT" "RlxBatch" "USB" "FX" "FIP" "LspUser1" "LspUser2" "LspUser2" "Spare"))
  (RlxGrMenu_Init)
  (RlxGrMenu_Doit)
  (RlxGrMenu_Exit)
  (princ)
)

(defun RlxGrMenu_Init ()(princ "\nUnder construction - RlxGrMenu_Init "))
(defun RlxGrMenu_Doit ()(princ "\nUnder construction - RlxGrMenu_Doit "))
(defun RlxGrMenu_Exit ()(princ "\nUnder construction - RlxGrMenu_Exit "))


(defun c:RlxGrMenu ()(draw_menu))
(defun c:t1 ()(draw_menu))
(defun t1 ()(draw_menu))

Edited 1 hour ago by rlx

Sign In

Just a funny / basic toolbar

Recommended Posts

rlx

GLAVCVS

rlx

mhupp

rlx

GLAVCVS

Steven P

SLW210

rlx

rlx

Join the conversation

Tutorials

Forums

Activity