TheSwamp

Code Red => AutoLISP (Vanilla / Visual) => Visual DCL Programming => Topic started by: Grrr1337 on February 25, 2017, 12:48:17 PM

Title: Prompt for justification
Post by: Grrr1337 on February 25, 2017, 12:48:17 PM
Hi guys,

(https://s17.postimg.org/ppr61ttsb/Get_Justification_DCL_Buttons.jpg)

I was about to ask if this is doable with using radio_buttons (3x3 matrix button display) but I've managed to figure it out bymyself.  :yay!:

(https://s17.postimg.org/hlj1x37d7/Get_Justification_DCL_Radios.jpg)

So I'm leaving this here, as a solution to help anyone:

Code - Auto/Visual Lisp: [Select]
  1. ; Use DCL to prompt for justification
  2. ; (GetJustificationDCL nil nil)
  3. ; (GetJustificationDCL nil T)
  4. ; (GetJustificationDCL "Move Option" nil)
  5. ; (GetJustificationDCL "Move Option" T)
  6. (defun GetJustificationDCL ( dlbl UseRadios / *error* b dcl des dch dcf rtn )
  7.  
  8.   (defun *error* ( msg )
  9.     (and (< 0 dch) (unload_dialog dch))
  10.     (and (eq 'FILE (type des)) (close des))
  11.     (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
  12.     (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)) ))
  13.     (princ)
  14.   ); defun *error*
  15.  
  16.   (setq b (if UseRadios ": radio_button" ": button"))
  17.  
  18.   (cond
  19.     (
  20.       (not
  21.         (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
  22.           (vl-every (function (lambda (x) (princ x des))); write-line / princ
  23.             (list
  24.               "Justification : dialog"
  25.               (strcat "{ label = \"" (if (eq 'STR (type dlbl)) dlbl "Choose Justification") "\";")
  26.               (if UseRadios " : radio_column " " : column ")
  27.               "  { : row { " b " { label = \"TL\"; key = \"TL\"; } " b " { label = \"TC\"; key = \"TC\"; } " b " { label = \"TR\"; key = \"TR\"; } } "
  28.               "    : row { " b " { label = \"ML\"; key = \"ML\"; } " b " { label = \"MC\"; key = \"MC\"; } " b " { label = \"MR\"; key = \"MR\"; } } "
  29.               "    : row { " b " { label = \"BL\"; key = \"BL\"; } " b " { label = \"BC\"; key = \"BC\"; } " b " { label = \"BR\"; key = \"BR\"; } } "
  30.               "  } "
  31.               "  spacer;"
  32.               "  ok_cancel; "
  33.               "  : text { label = \"\"; key = \"info\"; } "
  34.               "}"
  35.             ); list
  36.           ); mapcar
  37.           (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl)))
  38.         ); and
  39.       ); not
  40.       (princ "\nUnable to write or load the DCL file.")
  41.     )
  42.     ( (not (new_dialog "Justification" dch)) (princ "\nUnable to display the dialog.") )
  43.     (
  44.       (not
  45.         (and
  46.           (vl-every
  47.             (function
  48.               (lambda (x)
  49.                 (action_tile x
  50.                   (vl-prin1-to-string
  51.                     '(progn (if UseRadios (mapcar '(lambda (k) (set_tile k "0")) '("TL" "TC" "TR" "ML" "MC" "MR" "BL" "BC" "BR")))
  52.                       (set_tile $key "1") (setq rtn $key) (set_tile "info" (strcat "Chosen justification: " $key))
  53.                     )
  54.                   )
  55.                 )
  56.               )
  57.             )
  58.             '("TL" "TC" "TR" "ML" "MC" "MR" "BL" "BC" "BR")
  59.           ); vl-every
  60.           (action_tile "accept" (vl-prin1-to-string '(cond ( (not rtn) (set_tile "info" "Choose justification, please!") ) ( (done_dialog 1) ))))
  61.           (setq dcf (start_dialog))
  62.         ); and
  63.       ); not
  64.       (princ "\nUnable to start the dialog.")
  65.     )
  66.     ( (/= 1 dcf) (princ "\nUser cancelled the dialog.") (setq rtn nil) )
  67.   ); cond
  68.   (*error* nil) (princ) rtn
  69. ); defun GetJustificationDCL

Cheers!
Title: Re: Prompt for justification
Post by: Lee Mac on February 25, 2017, 01:11:42 PM
Nice one Grrr1337 - I see that your DCL skills are improving with every post  :-)

To offer another option in addition to buttons & radio_buttons, you could also use image_buttons - here are a couple of examples:

Justify Base Point (http://lee-mac.com/justifybasepoint.html)
DCL Bitmaps (https://www.theswamp.org/index.php?topic=41938.0) (See Text Wrapping example)
Title: Re: Prompt for justification
Post by: Grrr1337 on February 25, 2017, 01:39:02 PM
Thanks Lee!  :-)
The main reason for my improvement is that I'm learning most of the stuff from you, since you perfected everything in lisp. Thank god that you exist!
I don't think I'll ever become insane programmer like you - but I'm doing my best (slowly and surely) (my intention is to become insane CAD drafter).

hint about my intention with this: It will be used to justify SelectionSets (using move).
Title: Re: Prompt for justification
Post by: roy_043 on February 25, 2017, 04:05:39 PM
@Grrr1337: Try using the radio_cluster tile (https://www.theswamp.org/index.php?topic=3289.msg40703#msg40703).
Title: Re: Prompt for justification
Post by: Grrr1337 on February 25, 2017, 06:21:15 PM
Thanks Roy, I feel that I'm missing something.
However I just tried this and got this messy result :

(https://s13.postimg.org/bax58yzgn/image.jpg)

Heres the test code - using Keith's suggestion (and without manually resetting all the tile's values to 0 - for every action) :

Code - Auto/Visual Lisp: [Select]
  1. ; Radio_cluster test:
  2. (defun C:test ( / *error* dcl des dch rtn dcf )
  3.  
  4.   (defun *error* ( msg )
  5.     (and (< 0 dch) (unload_dialog dch))
  6.     (and (eq 'FILE (type des)) (close des))
  7.     (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
  8.     (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)) ))
  9.     (princ)
  10.   ); defun *error*
  11.  
  12.   (cond
  13.     (
  14.       (not
  15.         (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
  16.           (princ
  17.             (strcat
  18.               "Justification : dialog"
  19.               "{ label = \"test\";"
  20.               "  : radio_cluster"
  21.               "  { :row "
  22.               "    { : column "
  23.               "      { : radio_button { label = \"TL\"; key = \"TL\"; }"
  24.               "        : radio_button { label = \"TC\"; key = \"TC\"; }"
  25.               "        : radio_button { label = \"TR\"; key = \"TR\"; }"
  26.               "      }"
  27.               "      : column "
  28.               "      { : radio_button { label = \"ML\"; key = \"ML\"; }"
  29.               "        : radio_button { label = \"MC\"; key = \"MC\"; }"
  30.               "        : radio_button { label = \"MR\"; key = \"MR\"; }"
  31.               "      }"
  32.               "      : column "
  33.               "      { : radio_button { label = \"BL\"; key = \"BL\"; }"
  34.               "        : radio_button { label = \"BC\"; key = \"BC\"; }"
  35.               "        : radio_button { label = \"BR\"; key = \"BR\"; }"
  36.               "      }"
  37.               "    }"
  38.               "  }"
  39.               "  spacer;"
  40.               "  ok_cancel;"
  41.               "  : text { label = \"\"; key = \"info\"; } "
  42.               "}"
  43.             ); strcat
  44.             des
  45.           ); princ
  46.           (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl)))
  47.         ); and
  48.       ); not
  49.       (princ "\nUnable to write or load the DCL file.")
  50.     )
  51.     ( (not (new_dialog "Justification" dch)) (princ "\nUnable to display the dialog.") )
  52.     (
  53.       (not
  54.         (and
  55.           (vl-every
  56.             (function
  57.               (lambda (x)
  58.                 (action_tile x (vl-prin1-to-string '(progn (setq rtn $key) (set_tile "info" (strcat "Chosen justification: " $key)))))
  59.               )
  60.             )
  61.             '("TL" "TC" "TR" "ML" "MC" "MR" "BL" "BC" "BR")
  62.           ); vl-every
  63.           (action_tile "accept" (vl-prin1-to-string '(cond ( (not rtn) (set_tile "info" "Choose justification, please!") ) ( (done_dialog 1) ))))
  64.           (setq dcf (start_dialog))
  65.         ); and
  66.       ); not
  67.       (princ "\nUnable to start the dialog.")
  68.     )
  69.     ( (/= 1 dcf) (princ "\nUser cancelled the dialog.") (setq rtn nil) )
  70.     (rtn (alert rtn) )
  71.   ); cond
  72.   (*error* nil) (princ)
  73. ); defun C:test
  74.  

BTW Thats a nice thread, thanks!  :-)
Title: Re: Prompt for justification
Post by: roy_043 on February 27, 2017, 08:14:33 AM
I do not know why the radio_cluster does not work in this case. BricsCAD does not support this tile. Maybe somebody with an AutoCAD license can shed some light.
Title: Re: Prompt for justification
Post by: Lee Mac on February 27, 2017, 08:24:13 AM
I do not know why the radio_cluster does not work in this case. BricsCAD does not support this tile. Maybe somebody with an AutoCAD license can shed some light.

IIRC, I could never get it to work as expected.
Title: Re: Prompt for justification
Post by: MP on February 27, 2017, 09:12:25 AM
The ambitious might fake it with image tiles.
Title: Re: Prompt for justification
Post by: snownut2 on March 10, 2017, 11:15:44 AM
I've not been successful in getting multiple rows or columns of radio buttons to work in Bcad or ACAD.
Title: Re: Prompt for justification
Post by: Grrr1337 on June 09, 2017, 02:23:56 PM
The ambitious might fake it with image tiles.

I just couldn't avoid your reply,
So after practicing about working with DCL image manipulation, heres some sample (using image tiles) :

(https://gifyu.com/images/ImageButtonsHandling.gif)


Code - Auto/Visual Lisp: [Select]
  1.  
  2. ; About Handling Image Buttons (assign action depending on the clicked portion of an image)
  3.  
  4. ; 1. Create Dialog with image that looks like this:
  5. ; A B C
  6. ; D E F
  7. ; G H I
  8. ; 2. When Double clicking on the image, depending on the portion - return the according value
  9.  
  10. ; Grrr
  11. ; WORKS
  12. ; This dialog demonstrates the simple usage of image_button
  13. ; Assign/display the actual image on the image_button/image
  14. ; and assign action to the image_button
  15. (defun C:test ( / PutImgVal *error* dcl des dch dcf imgL jL )
  16.  
  17.   (setq PutImgVal ; image that visually can be splitted on 9 quadrants by the user
  18.     '(lambda (BG TL TC TR ML MC MR BL BC BR / )
  19.       (list ; BG = 250 ; Empty = -15 ; Filled = 023
  20.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  21.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  22.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  23.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  24.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  25.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  26.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  27.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  28.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  29.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  30.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  31.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  32.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  33.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  34.         BG BG TL TL TL TL TL TL TL TL TL TL TL TL TL BG BG TC TC TC TC TC TC TC TC TC TC TC TC TC TC BG BG TR TR TR TR TR TR TR TR TR TR TR TR TR BG BG
  35.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  36.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  37.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  38.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  39.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  40.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  41.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  42.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  43.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  44.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  45.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  46.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  47.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  48.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  49.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  50.         BG BG ML ML ML ML ML ML ML ML ML ML ML ML ML BG BG MC MC MC MC MC MC MC MC MC MC MC MC MC MC BG BG MR MR MR MR MR MR MR MR MR MR MR MR MR BG BG
  51.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  52.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  53.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  54.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  55.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  56.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  57.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  58.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  59.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  60.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  61.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  62.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  63.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  64.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  65.         BG BG BL BL BL BL BL BL BL BL BL BL BL BL BL BG BG BC BC BC BC BC BC BC BC BC BC BC BC BC BC BG BG BR BR BR BR BR BR BR BR BR BR BR BR BR BG BG
  66.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG
  67.         BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG BG    
  68.       ); list
  69.     ); lambda
  70.   ); setq PutImgVal
  71.  
  72.   (defun *error* ( msg )
  73.     (and (< 0 dch) (unload_dialog dch))
  74.     (and (eq 'FILE (type des)) (close des))
  75.     (and (eq 'STR (type dcl)) (findfile dcl) (vl-file-delete dcl))
  76.     (and msg (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\nError: " msg)) ))
  77.     (princ)
  78.   ); defun *error*
  79.  
  80.   (cond
  81.     (
  82.       (not
  83.         (and (setq dcl (vl-filename-mktemp nil nil ".dcl")) (setq des (open dcl "w"))
  84.           (mapcar (function (lambda (x) (princ x des)))
  85.             '("imgtest : dialog"
  86.               "{ label = \"Image Test\";"
  87.               "  : column"
  88.               "  { : image_button { key = \"img\"; fixed_width = true; fixed_height = true; width = 6.25; aspect_ratio = 1.0; alignment = centered; } " ; 48x48 image
  89.               "    : edit_box { key = \"eb\"; label = \"info\"; alignment = centered; edit_width = 12; fixed_width = true; is_enabled = false; value = \"\"; }" ; info
  90.               "  }"
  91.               "  spacer; ok_cancel; : text { key = \"error\"; }"
  92.               "}"
  93.             )
  94.           ); mapcar
  95.           (not (setq des (close des))) (< 0 (setq dch (load_dialog dcl)))
  96.         ); and
  97.       ); not
  98.       (princ "\nUnable to write or load the DCL file.")
  99.     )
  100.     ( (not (new_dialog "imgtest" dch)) (princ "\nUnable to display the dialog") )
  101.     (
  102.       (progn
  103.         (setq jL '(("TL" . -15) ("TC" . -15) ("TR" . -15) ("ML" . -15) ("MC" . -15) ("MR" . -15) ("BL" . -15) ("BC" . -15) ("BR" . -15)))
  104.         (setq imgL (apply PutImgVal (cons 250 (mapcar 'cdr jL)))) ; initially display with empty cells
  105.         (LM:DisplayBitmap "img" imgL)
  106.         (action_tile "img"
  107.           (vl-prin1-to-string
  108.             '( ; PickImg
  109.               (lambda ( key val rsn x y / qdr itm j )
  110.                 (setq qdr ; Remember that the Origin is at the upper left
  111.                   ( ; Determine the quadrant
  112.                     (lambda (x y w h / wdiv hdiv )
  113.                       (setq wdiv (/ w 3.)) (setq hdiv (/ h 3.)) ; divide the image on 3x3 quadrants
  114.                       (list
  115.                         (cond
  116.                           ( (< (* hdiv 0.) y (* hdiv 1.)) 1 )
  117.                           ( (< (* hdiv 1.) y (* hdiv 2.)) 2 )
  118.                           ( (< (* hdiv 2.) y (* hdiv 3.)) 3 )
  119.                         ); cond
  120.                         (cond
  121.                           ( (< (* wdiv 0.) x (* wdiv 1.)) 1 )
  122.                           ( (< (* wdiv 1.) x (* wdiv 2.)) 2 )
  123.                           ( (< (* wdiv 2.) x (* wdiv 3.)) 3 )
  124.                         ); cond
  125.                       ); list
  126.                     ); lambda
  127.                     x y (dimx_tile key) (dimy_tile key) ; Obtain the image size
  128.                   )
  129.                 ); setq qdr
  130.                 (and
  131.                   (setq itm
  132.                     (assoc qdr ; does (assoc) work on complex associations? - yes, atleast on list associations
  133.                       '(
  134.                         ((1 3) "TL") ((1 2) "TC") ((1 1) "TR")
  135.                         ((2 3) "ML") ((2 2) "MC") ((2 1) "MR")
  136.                         ((3 3) "BL") ((3 2) "BC") ((3 1) "BR")
  137.                       )
  138.                     ); assoc
  139.                   ); setq itm
  140.                   (setq j (cadr itm)) ; the justification
  141.                   (cond ; fill with different color the picked range, depending on the type of click
  142.                     ( (= 1 rsn) ; User clicked once
  143.                       (set_tile "eb" (strcat "Sclick: "(vl-prin1-to-string j)))
  144.                       (LM:DisplayBitmap "img" (apply PutImgVal (cons 250 (mapcar 'cdr (subst (cons j 023) (assoc j jL) jL)))))
  145.                     ); (= 1 rsn) ; User clicked once
  146.                     ( (= 4 rsn) ; User Double-Clicked
  147.                       (set_tile "eb" (strcat "Dclick: "(vl-prin1-to-string j)))
  148.                       (LM:DisplayBitmap "img" (apply PutImgVal (cons 250 (mapcar 'cdr (subst (cons j 010) (assoc j jL) jL)))))
  149.                     ); (= 4 rsn) ; User Double-Clicked
  150.                   ); cond
  151.                 ); and
  152.               ); lambda
  153.               $key $value $reason $X $Y
  154.             ); PickImg
  155.           ); vl-prin1-to-string
  156.         ); action_tile "img"
  157.         (action_tile "accept" "(done_dialog 1)")
  158.         (/= 1 (setq dcf (start_dialog)))
  159.       ); progn
  160.       (princ "\nUser cancelled the dialog.")
  161.     )
  162.     (T nil)
  163.   ); cond
  164.   (*error* nil) (princ)
  165. ); defun
  166.  
  167.  
  168. ;;--------------------=={ Display Bitmap }==------------------;;
  169. ;;                                                            ;;
  170. ;;  Renders the supplied ACI colour list representation of a  ;;
  171. ;;  Bitmap image on the DCL image tile or image_button tile   ;;
  172. ;;  with the given key.                                       ;;
  173. ;;------------------------------------------------------------;;
  174. ;;  Author: Lee Mac, Copyright © 2012 - www.lee-mac.com       ;;
  175. ;;------------------------------------------------------------;;
  176. ;;  Arguments:                                                ;;
  177. ;;  key - key of DCL image tile or image_button tile          ;;
  178. ;;  lst - ACI colour list                                     ;;
  179. ;;------------------------------------------------------------;;
  180. ;;  Returns:  nil                                             ;;
  181. ;;------------------------------------------------------------;;
  182.  
  183. (defun LM:DisplayBitmap ( key lst / i j s x y )
  184.   (setq s (fix (sqrt (length lst))))
  185.   (repeat (setq i s)
  186.     (setq j 1)
  187.     (repeat s
  188.       (setq x (cons j x)
  189.         y (cons i y)
  190.         j (1+ j)
  191.       )
  192.     )
  193.     (setq i (1- i))
  194.   )
  195.   (start_image key)
  196.   (fill_image 0 0 (dimx_tile key) (dimy_tile key) -15)
  197.   (mapcar 'vector_image x y x y lst)
  198. )

Sorry about the small image, I was lazy to adjust the image-pixels in NP++, rather focusing on the technique/performance.