home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 18 REXX / 18-REXX.zip / rexxtk12.zip / demo / testtk.rexx < prev   
OS/2 REXX Batch file  |  2001-05-15  |  16KB  |  491 lines
  1. /**/
  2. Call Rxfuncadd 'TkLoadFuncs','rexxtk','TkLoadFuncs'
  3. If TkLoadFuncs() \= 0 Then exit
  4.  
  5. Call Rxfuncadd 'TkTreeLoadFuncs','rexxtktree','TkTreeLoadFuncs'
  6. If TkTreeLoadFuncs(TkGetBaseData()) \= 0 Then exit
  7.  
  8. Call Rxfuncadd 'TkComboboxLoadFuncs','rexxtkcombobox','TkComboboxLoadFuncs'
  9. If TkComboboxLoadFuncs(TkGetBaseData()) \= 0 Then exit
  10.  
  11. Trace o
  12.  
  13. /* a test Tcl command to see the Tcl interpreter working */
  14. rc = TkTcl('puts','HI')
  15.  
  16. Say 'You are running' TkVariable('VERSION') 'using Tcl/Tk' TkVar('tk_version')
  17.  
  18. /* create the main window */
  19. Call CreateMain
  20.  
  21. /* This is a typical dispatch loop if you set the "rexx"
  22.    options in the widgets to be a name of a subroutine that
  23.    you write (like below). */
  24. do forever
  25.    /* TkWait returns whatever you typed as the value of the
  26.       "rexx" option for whatever control is pushed, moved,
  27.       chosen, etc */
  28.    interpret 'call' TkWait()
  29. /*
  30.    rc = TkWait()
  31.    cmd = Word(rc,1)
  32.    args = SubWord(rc,2)
  33.    interpret 'call' cmd '"'args'"'
  34. */
  35. end
  36.  
  37. return 0
  38.  
  39. CreateMain:
  40.  
  41.    /* 
  42.     * make the main window menu 
  43.     */
  44.  
  45.    /* make a menu that will be our menubar; only one per toplevel window */
  46.    menubar = TkMenu('.m1')
  47.  
  48.    /* Add a File menu to the menubar.  The file
  49.       menu will 'cascade' off of the menu bar */
  50.  
  51.    /* Create another menu widget to be our file menu
  52.       and tell the menubar menu about it... the "tearoff"
  53.       option, well, just remove it and see what happens.*/
  54.    filemenu = TkMenu('.m1.file','-tearoff', 0)
  55.    /* Add the menu to the top-level menubar */
  56.    call TkAdd menubar, 'cascade', '-label', 'File', '-menu', filemenu
  57.  
  58.    /* now add items to the File menu */
  59.    call TkAdd filemenu, 'command', '-label', 'Test...', '-rexx', 'AnotherWin'
  60.    call TkAdd filemenu, 'command', '-label', 'Tree...', '-rexx', 'OpenTree'
  61.    call TkAdd filemenu, 'command', '-label', 'Open...', '-rexx', 'GetFileName'
  62.    call TkAdd filemenu, 'command', '-label', 'Dir...', '-rexx', 'GetDirectory'
  63.  
  64.    /* adding another item... but am using
  65.       the 'array' options method just for
  66.       grins */
  67.    call SetArgs 'clear'
  68.    call SetArgs 'label', 'Quit'
  69.    call SetArgs 'rexx', 'exit'
  70.    call TkAdd filemenu, 'command', 'n.', 'v.'
  71.  
  72.    /* Create another top-level menu item to demonstrate menus */
  73.    cascademenu = TkMenu('.m1.cascade','-tearoff', 0)
  74.    /* Add it to the top-level menubar */
  75.    call TkAdd menubar, 'cascade', '-label', 'MenuTest', '-menu', cascademenu
  76.  
  77.    /* Create a radio-button sub-menu to be called from the "Cascade" menu */
  78.    rbmenu = TkMenu('.m1.cascade.radio', '-tearoff', 0)
  79.    Call tkadd rbmenu, 'command', '-label', "Font Size"
  80.    Call tkadd rbmenu, 'radio', '-label', "10 point", '-variable', 'pointSize' , '-value', 10
  81.    Call tkadd rbmenu, 'radio', '-label', "14 point", '-variable', 'pointSize' , '-value', 14
  82.    Call tkadd rbmenu, 'radio', '-label', "18 point", '-variable', 'pointSize' , '-value', 18
  83.    Call tkadd rbmenu, 'radio', '-label', "24 point", '-variable', 'pointSize' , '-value', 24
  84.    Call tkadd rbmenu, 'separator'
  85.    Call tkadd rbmenu, 'command', '-label', "Appearence"
  86.    Call tkadd rbmenu, 'check', '-label', "Bold", '-variable', 'fontbold'
  87.    Call tkadd rbmenu, 'check', '-label', "Italic", '-variable', 'fontitalic'
  88.    Call tkadd rbmenu, 'check', '-label', "Underline", '-variable', 'fontunderline'
  89.    /* Add it to the cascade menu */
  90.    call TkAdd cascademenu, 'cascade', '-label', 'Font Stuff', '-menu', rbmenu
  91.  
  92.    /* Now we have all of the menus setup, attach the top-level menubar */
  93.    /* to the main window */
  94.    call TkConfig '.', '-menu', menubar
  95.  
  96.    /* end of menu setup */
  97.  
  98.    /* create a frame to put a row of buttons in */
  99.    f1 = TkFrame('.f1')
  100.  
  101.    /* create each button and remember the name */
  102.    text = 'Press Me!'
  103.    rexx = 'YesButton'
  104.    b1 = TkButton(f1'.b1', 'text', 'rexx')
  105.  
  106.    text = 'No'
  107.    rexx = 'NoButton'
  108.    b2 = TkButton(f1'.b2', 'text', 'rexx')
  109.  
  110.    text = 'Count'
  111.    rexx = 'CountToggle'
  112.    b3 = TkButton(f1'.b3', 'text', 'rexx')
  113.  
  114.    cb = TkCombobox(f1'.cb','-editable','false','-highlightthickness', 1)
  115.    If rc \= 0 Then Say rc TkError()
  116.    Call TkConfig cb, '-textvariable', 'family'
  117.    If rc \= 0 Then Say rc TkError()
  118.    Call TkComboboxListInsert cb, 'end', 'value1', 'value2'
  119.    /* "pack" the buttons... since we created them
  120.       under the "frame" by naming them that way, they
  121.       will be packed into the frame (.f1).
  122.       We pack them with the option "side" = "left"
  123.       which is like sliding (or packing)  them into
  124.       the frame toward the left side... */
  125.    call TkPack b1,  b2,  b3,  '-side',  'left'
  126.    call TkPack cb, '-side', 'bottom'
  127.  
  128.    /* now create a label widget - it's blank for now */
  129.    prompt = TkLabel('.l1')
  130.  
  131.    /* create an entry widget... notice how we use the
  132.       'dash' method of specifying the options here
  133.       since there is only one option we are setting */
  134.    entry = TkEntry('.e1', '-width', 20)
  135.  
  136.    /*
  137.     * Create a canvas and add some objects to it...
  138.     */
  139.    canvas = TkCanvas('.canvas1', '-width', '10c', '-height', '10c')
  140.    outlinerect = TkCanvasRectangle(canvas, 5, 5, 30, 20, '-outline', 'red', '-width', '3')
  141.    fillrect = TkCanvasRectangle(canvas, '1c', '1c', '4c', '5c', '-fill', 'green', '-width', '3')
  142.    arc = TkCanvasOval(canvas, 15, 15, '5c', '2c', '-width', '2m', '-outline', 'black')
  143.    text = TkCanvasText(canvas, '5c', '8c', '-width', '4c', '-anchor', 'center', '-text', 'Here is some text. It should hopefully wrap around to the next line.')
  144.    line = TkCanvasLine(canvas, '8c', '4c', '3c', '2c', '1c', '9c', '7.7c' , '3.5c') 
  145. /*   poly = TkCanvasPolygon(canvas, '8c', '4c', '3c', '2c', '1c', '9c', '7.7c' , '3.5c', '-fill', 'blue', '-width' ,1) */
  146.    Call TkCanvasBind canvas, outlinerect, '<Any-Enter>', '*EnterObject %W'
  147.    Call TkCanvasBind canvas, arc, '<Any-Enter>', '*EnterObject %W'
  148.    Call TkCanvasBind canvas, outlinerect, '<Any-Leave>', '*LeaveObject %W'
  149.    Call TkCanvasBind canvas, arc, '<Any-Leave>', '*LeaveObject %W'
  150.    Call TkCanvasBind canvas, fillrect, '<Any-Enter>', '*EnterFillRect %W'
  151.    Call TkCanvasBind canvas, fillrect, '<Any-Leave>', '*LeaveFillRect %W'
  152.  
  153.    /* Now pack the frame, the entry, the canvas, and the prompt.
  154.       Since they are all named with names at the
  155.       "root" then they are children of the main window
  156.       and will be packed into that.  We are not saying
  157.       which side to pack towards, so it assumes the top. */
  158.    call TkPack f1, entry, prompt, canvas
  159.  
  160.    /* Finally, set some file types and associated extensions
  161.       for the TkGetOpenFile call used in the GetFileName
  162.       routine.*/
  163.    call TkSetFileType 'Text', '.txt'
  164.    call TkSetFileType 'Program Source', '.c', '.h', '.rexx'
  165.    call TkSetFileType 'All', '*'
  166.  
  167.    return
  168.  
  169. /* the "press me" button was pressed */
  170. YesButton:
  171.    procedure expose fillrect canvas
  172.    
  173.    /* Config changes the configuration of the widget
  174.       given as argument one. */
  175.    call TkConfig '.l1', '-text', 'You deleted the green rectangle!'
  176.    
  177.    /* Wm does alot.  Here we are setting the title
  178.       of the window given in arg 2 (the root window) */
  179.    call TkWm 'title', '.', TkGet('.e1')
  180.    
  181.    call tkcanvasdelete canvas, fillrect
  182.    /* delete the text out of the '.e1' widget which is
  183.       the text 'entry' widget we created with the
  184.       TkEntry call in the main routine.  The 2nd and
  185.       3rd args are the beginning and end of the range
  186.       that we want deleted. */
  187.    call TkDelete '.e1', 0, 'end'
  188.    return
  189.  
  190. NoButton:
  191.    procedure expose prompt canvas
  192.    n.1 = 'text'
  193.    v.1 = 'What? No?'
  194.    call TkConfig prompt, 'n.', 'v.'
  195.    call TkWm 'title', '.', 'Hi Dudez'
  196.    call TkCanvasPostscript canvas, '-file', 'aaa.ps'
  197.  
  198.    return
  199.  
  200. EnterObject: Procedure Expose canvas restorecmd
  201.    Parse Arg obj
  202.    type = TkCanvasType( canvas, 'current' )
  203.    Select
  204.       When type = 'rectangle' Then 
  205.          Do
  206.             Call TkItemConfig canvas, 'current', '-outline', 'blue'
  207.             restorecmd = "TkItemConfig canvas, 'mycurr', '-outline', 'red'"
  208.          End
  209.       When type = 'oval' Then 
  210.          Do
  211.             Call TkItemConfig canvas, 'current', '-outline', 'red'
  212.             restorecmd = "TkItemConfig canvas, 'mycurr', '-outline', 'black'"
  213.          End
  214.       Otherwise Nop
  215.    End
  216.    Call TKCanvasAddtag canvas, 'mycurr', 'withtag', 'current'
  217.    Return
  218.  
  219. LeaveObject: Procedure Expose canvas restorecmd
  220.    Parse Arg obj
  221.    Interpret 'call' restorecmd
  222.    Call TKCanvasDtag canvas, 'mycurr'
  223.    Return
  224.  
  225. EnterFillRect: Procedure Expose restorecmd fillrect
  226.    Parse Arg win .
  227.    Call TkItemConfig win, 'current', '-fill', 'white'
  228.    restorecmd = "TkItemConfig win , fillrect, '-fill', 'green'"
  229.    Return
  230.  
  231. LeaveFillRect: Procedure Expose restorecmd fillrect
  232.    Parse Arg win .
  233.    Interpret 'call' restorecmd
  234.    Return
  235.  
  236. SlidePrompt:
  237.    parse arg nbr
  238.    text = 'Slider set to' nbr
  239.    call TkConfig '.l1', 'text'
  240.    return
  241.  
  242. GetFileName:
  243.  
  244.    /* The file extensions/types are being set up
  245.       in the main window init rouine (CreateMain) */
  246.  
  247.    FileName = TkGetOpenFile('-title','Open File')
  248.    
  249.    /* set the text prompt to the filename */
  250.    call TkConfig '.l1', '-text', FileName
  251.    
  252.    return
  253.  
  254. GetDirectory:
  255.  
  256.    DirName = TkChooseDirectory('-title','Choose Directory')
  257.    
  258.    /* set the text prompt to the dirname */
  259.    call TkConfig '.l1', '-text', DirName
  260.    
  261.    return
  262.  
  263. quit:
  264. exit:
  265.    if TkMessageBox('-message','Are you sure you want to quit?','-title','Quit?','-type','yesno','-icon','warning'),
  266.       = 'no' then
  267.       return
  268.    exit
  269.  
  270. SetArgs:
  271.    procedure expose  n. v.
  272.    Parse Arg name, value
  273.    if name = 'clear' then
  274.       do
  275.          drop n. v.
  276.          n.0 = 0
  277.          return 0
  278.       end
  279.    n.0 = n.0 + 1
  280.    v.0 = n.0
  281.    argc = n.0
  282.    n.argc = name
  283.    v.argc = value
  284.    return 0
  285.  
  286. AnotherWin:
  287.    procedure 
  288.  
  289.    win = TkTopLevel('.win2')
  290.  
  291.    l1 = TkLabel(win'.l1', '-text', 'Pick a number from 100 to 200')
  292.  
  293.    text = 'Done'
  294.    rexx = 'AWinClose'
  295.    b1 = TkButton(win'.b1', 'text', 'rexx')
  296.    
  297.    /* a perfect time to use the array options
  298.       setting method since there are so many
  299.       options we want to set on this widget */
  300.    call SetArgs 'clear'
  301.    call SetArgs 'from', 100
  302.    call SetArgs 'to', 200
  303.    call SetArgs 'orient', 'horiz'
  304.    call SetArgs 'tickinterval', 50
  305.    call SetArgs 'length', 200
  306.    call SetArgs 'rexx', 'SlidePrompt'
  307.    scale = TkScale(win'.s1', 'n.', 'v.')
  308.    
  309.    call TkPack l1, scale, b1
  310.  
  311.    /* this will prevent any other window
  312.       from receiving any input */
  313.    call TkGrab win
  314.  
  315.    do forever
  316.       cmd = TkWait()
  317.       if cmd = 'AWinClose' then leave
  318.       interpret 'call' cmd
  319.    end
  320.  
  321.    /* allow all the other windows
  322.       to receive input as normal */
  323.    call TkGrab 'release', win
  324.   
  325.    /* before we destroy (and quit displaying)
  326.       the window, we need the value of the
  327.       scale widget... the number they picked. */
  328.    choice = TkGet(scale)
  329.  
  330.    /* set the prompt in the main window with it */
  331.    call TkConfig '.l1', '-text', 'You chose:' choice
  332.    
  333.    /* now destroy the main window and all the
  334.       child widgets in it */
  335.    call TkDestroy win
  336.    
  337.    return
  338.  
  339. OpenTree:
  340.    procedure 
  341.  
  342.    win = TkTopLevel('.win3')
  343.    Call TkConfig win, '-bd', 3, '-relief', 'flat'
  344.    frame = TkFrame(win'.f', '-bg', 'white' )
  345.    Call TkPack frame, '-fill', 'both', '-expand', 1
  346.  
  347.    l1 = TkLabel(frame'.l1', '-text', 'Tree Demo')
  348.  
  349.    text = 'Done'
  350.    rexx = 'TreeClose'
  351.    b1 = TkButton(frame'.b1', 'text', 'rexx')
  352.    
  353.    /*
  354.     * Create a frame for the tree and scrollbar
  355.     */
  356.    tree = TkTree( frame'.t1', '-width', 150, '-height', 400, '-yscrollcommand', frame'.sb set' )
  357.    sb = TkScrollbar( frame'.sb', '-orient', 'vertical', '-command', tree 'yview')
  358.    Call TkPack tree, '-side', 'left', '-fill', 'both', '-expand', 1, '-padx', 5, '-pady', 5
  359.    Call TkPack sb, '-side', 'left', '-fill', 'y'
  360.    idir_data = "R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4APj4+P///wAAAAAAACwAAAAAEAAQAAADPVi63P4wLkKCtTTnUsXwQqBtAfh910UU4ugGAEucpgnLNY3Gop7folwNOBOeiEYQ0acDpp6pGAFArVqthQQAO///"
  361.    Call TkImagePhoto 'idir', '-data', idir_data
  362.    ifile_data = "R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4+P///wAAAAAAAAAAACwAAAAAEAAQAAADPkixzPODyADrWE8qC8WN0+BZAmBq1GMOqwigXFXCrGk/cxjjr27fLtout6n9eMIYMTXsFZsogXRKJf6uP0kCADv/"
  363.    Call TkImagePhoto 'ifile', '-data', ifile_data
  364.    /*
  365.     * Create another frame beside the tree frame for the filename
  366.     * contents
  367.     */
  368.    frame2 = TkFrame( frame'.f2', '-height', 400, '-width', 400, '-bg', 'white')
  369.    Call TKPack frame2, '-side', 'left', '-fill', 'both', '-expand', 1
  370.    label = TkLabel( frame2'.l', '-width', 40, '-text', '', '-bg', TkCget( frame, '-bg') )
  371.    Call TkPack label, '-expand', 1
  372.    Call TkPack b1, '-side', 'bottom'
  373.  
  374.    Do i = 1 To 3
  375.       Call TkTreeAddNode tree, '/dir'i, '-image', 'idir', '-tags', 'idir'
  376.       Do j = 1 To 6
  377.          Call TkTreeAddNode tree, '/dir'i'/file'j, '-image', 'ifile', '-tags', 'ifile'
  378.       End
  379.       Call TkTreeAddNode tree, '/dir'i'/subdir', '-image', 'idir', '-tags', 'idir'
  380.       Do k = 1 To 2
  381.          Call TkTreeAddNode tree, '/dir'i'/subdir/file'k, '-image', 'ifile', '-tags', 'ifile'
  382.       End
  383.       Do  zz = 1 To 4
  384.          Call TkTreeAddNode tree,'/dir'i'/subdir/ssdir'zz, '-image', 'idir', '-tags', 'idir'
  385.          Call TkTreeAddNode tree,'/dir'i'/subdir/ssdir'zz'/file1', '-tags', 'ifile'
  386.          Call TkTreeAddNode tree,'/dir'i'/subdir/ssdir'zz'/file2', '-image', 'ifile', '-tags', 'ifile'
  387.       End
  388.    End
  389.    Call TkCanvasBind tree, 'idir', '<1>', '*ClickOneDir %W %x %y'
  390.    Call TkCanvasBind tree, 'idir', '<2>', '*ClickTwoDir %W %x %y'
  391.    Call TkCanvasBind tree, 'ifile', '<1>', '*ClickOneFile %W %x %y'
  392.    Call TkCanvasBind tree, 'ifile', '<2>', '*ClickTwoFile %W %x %y'
  393.    Call TkCanvasBind tree, 'idir', '<Double-1>', '*DoubleClickOneDir %W %x %y'
  394.  
  395.    /* this will prevent any other window
  396.       from receiving any input */
  397.    call TkGrab win
  398.  
  399.    do forever
  400.       cmd = TkWait()
  401.       command = Word(cmd,1)
  402.       args = Strip(Subword(cmd,2),'B','"')
  403.       Select
  404.          When command = 'TreeClose' Then leave
  405.          When command = 'ClickOneDir' Then
  406.             Do
  407.                Parse var args window x y
  408.                lab = TkTreeGetLabel( window, x, y )
  409.                Call TkTreeSetSelection window, lab
  410.                Call TkConfig label, '-text', 'dir:' lab
  411.             End
  412.          When command = 'ClickOneFile' Then
  413.             Do
  414.                Parse var args window x y
  415.                lab = TkTreeGetLabel( window, x, y )
  416.                Call TkTreeSetSelection window, lab
  417.                Call TkConfig label, '-text', 'file:' lab
  418.             End
  419.          When command = 'ClickTwoDir' | command = 'ClickTwoFile' Then
  420.             Do
  421.                Parse var args window x y
  422.                lab = TkTreeGetLabel( window, x, y )
  423.                Call TkTreeDNode window, lab
  424.             End
  425.          When command = 'DoubleClickOneDir' Then
  426.             Do
  427.                Parse var args window x y
  428.                Call TkTreeOpen window, TkTreeGetLabel( window, x, y )
  429.             End
  430.          Otherwise interpret 'call' cmd
  431.       End
  432.    end
  433.  
  434.    /* allow all the other windows
  435.       to receive input as normal */
  436.    call TkGrab 'release', win
  437.   
  438.    /* now destroy the main window and all the
  439.       child widgets in it */
  440.    call TkDestroy win
  441.    
  442.    return
  443.    
  444. CountToggle:
  445.  
  446.    /* If there is already a CountID, then
  447.       we need to stop the counter, if not
  448.       then we start it.*/
  449.    If CountID = 'COUNTID' Then Do
  450.       
  451.       /* set a call to be made in one second */
  452.       CountID = TkAfter(1000, 'Count')
  453.  
  454.       /* Set the global var to 0 */
  455.       Count = 0
  456.  
  457.       /* call it here the first time for immediate
  458.          feedback */
  459.       Call Count
  460.  
  461.    End
  462.    Else Do
  463.       
  464.       /* Cancel the next call */
  465.       call TkAfter 'cancel', CountID
  466.  
  467.       /* Clear the CountID */
  468.       Drop CountID
  469.  
  470.       /* And clear the prompt */
  471.       call TkConfig '.l1', '-text', ''
  472.  
  473.    End
  474.  
  475.    Return
  476.    
  477. Count:
  478.  
  479.    /* increment the count */
  480.    Count = Count + 1
  481.  
  482.    /* set the prompt */
  483.    call TkConfig '.l1', '-text', 'Counting...' Count
  484.  
  485.    /* Set up another call to this routine
  486.       one second from now */
  487.    CountID = TkAfter(1000, 'Count')
  488.  
  489.    return
  490.  
  491.