home *** CD-ROM | disk | FTP | other *** search
/ The Developer Connection…ice Driver Kit for OS/2 3 / DEV3-D1.ISO / devtools / dataflex / sysbutn.pkg < prev    next >
Encoding:
Text File  |  1993-05-19  |  10.1 KB  |  363 lines
  1. //
  2. // SysButn.Pkg
  3. // January 23, 1991
  4. // Theo van Dongeren
  5. //
  6. // Package for system menu button
  7. //
  8. // Includes rubberband-moving of parent with right-hand mouse button
  9. //
  10. // Assumption:
  11. //
  12. // - Instance of system_button is owned by an object that has its own
  13. //   physical (not shared...) image.
  14. //
  15. // Example:
  16. //
  17. // /a_client
  18. // ┌─[_]─────────┐
  19. // │             │
  20. // │ blabla      │
  21. // │   blabla    │
  22. // │             │
  23. // └─────────────┘
  24. // /a_menu
  25. // ┌────────┐
  26. // │ ______ │
  27. // │ ______ │
  28. // └────────┘
  29. // /*
  30. //
  31. // object a_client is a client
  32. //   :
  33. //   sub_page sysbutton from a_client 1
  34. //
  35. //   object sysbutton is a system_button
  36. //     item_list
  37. //       on_item '≡' send yo
  38. //     end_item_list
  39. //   end_object
  40. //
  41. //   on_key key_alt+key_f10 send activate to (sysbutton(current_object))
  42. //
  43. //   object a_menu is a menu
  44. //     set popup_state to true
  45. //     set location to 1 0 relative
  46. //
  47. //     on_key kcancel send deactivate private
  48. //
  49. //     item_list
  50. //       :
  51. //     end_item_list
  52. //   end_object
  53. //   :
  54. //   procedure yo
  55. //     send popup to (a_menu(current_object))
  56. //   end_procedure
  57. //   :
  58. // end_object
  59. //
  60. // Notes:
  61. //
  62. // - YOU must provide the item list for the system button (see example above).
  63. // - System buttons are pointer_only by default.
  64. // - Sending ACTIVATE to a system button will cause the item message of item 
  65. //   zero to be sent (in above example; sending ACTIVATE to sysbutton
  66. //   will cause YO to be sent; which pops up the system menu.
  67. //
  68.  
  69. #CHKSUB 1 1 // Verify the UI subsystem.
  70.  
  71. use ui
  72.  
  73. // help class to draw draggable borders
  74. class border is a vconsole
  75.   procedure construct_object integer image
  76.     forward send construct_object image
  77.  
  78.     property string borderchars public '...'
  79.   end_procedure
  80.  
  81.   // this initializes the virtual console's size and contents
  82.   procedure initialize integer rows integer cols
  83.     local integer index maxindex
  84.     local string chars
  85.  
  86.     // set the size
  87.     set size to rows cols
  88.  
  89.     // clear it
  90.     send delete_data
  91.  
  92.     // find greatest dimension
  93.     move (rows max cols) to maxindex
  94.  
  95.     // get chars to use for drawing
  96.     get borderchars to chars
  97.  
  98.     // turn it on (redirect output to it)
  99.     send virtual_console
  100.  
  101.     // fill it
  102.     show (left(chars,1))
  103.     for index from 2 to (maxindex - 1)
  104.       show (mid(chars,1,2))
  105.     loop
  106.     show (right(chars,1))
  107.  
  108.     // turn it off (redirect output back to the desktop)
  109.     send virtual_console to desktop
  110.   end_procedure
  111.  
  112.   // this msg sent by desktop; informs parent that mouse has moved
  113.   procedure mouse_drag2 integer win# integer col#
  114.     forward send mouse_drag2 win# col#
  115.  
  116.     // tell parent that the mouse has moved
  117.     send drag_me
  118.   end_procedure
  119.  
  120.   // this msg sent by parent; sets new location of virtual console
  121.   procedure relocate integer rel_row integer rel_col
  122.     local integer complex
  123.     local integer old_row old_col
  124.  
  125.     // get the current location
  126.     get location to complex
  127.     move (hi(complex)) to old_row
  128.     move (low(complex)) to old_col
  129.  
  130.     // set a new location
  131.     set location to (old_row + rel_row) (old_col + rel_col)
  132.   end_procedure
  133.  
  134.   // this msg sent by desktop; tells parent to stop dragging
  135.   procedure mouse_up2 integer win# integer col#
  136.     forward send mouse_up2 win# col#
  137.  
  138.     // tell parent to stop dragging and drop its parent here
  139.     send drop_me
  140.   end_procedure
  141. end_class
  142.  
  143. // this is the draggable border
  144. class rubberband is a client
  145.   procedure construct_object integer image
  146.     local integer complex
  147.     local integer x1 y1 x2 y2
  148.  
  149.     forward send construct_object no_image
  150.  
  151.     property integer old_mouse_row public
  152.     property integer old_mouse_col public
  153.     property integer max_obj_row public
  154.     property integer max_obj_col public
  155.  
  156.     set popup_state to true
  157.  
  158.     // create top border segment
  159.     object tb is a border
  160.       set borderchars to '┌─┐' // change this to your liking
  161.     //                    ^^^
  162.     //                    ││└─> this one used for last char only
  163.     //                    │└──> this one used for all intermediate chars
  164.     //                    └───> this one used for first char only
  165.     end_object
  166.  
  167.     // create left border segment
  168.     object lb is a border 
  169.       set borderchars to '┌│└' // change this to your liking
  170.     end_object
  171.  
  172.     // create bottom border segment
  173.     object bb is a border 
  174.       set borderchars to '└─┘' // change this to your liking
  175.     end_object
  176.  
  177.     // create right border segment
  178.     object rb is a border 
  179.       set borderchars to '┐│┘' // change this to your liking
  180.     end_object
  181.  
  182.     // get size of outermost object
  183.     delegate get hsize to x1
  184.     delegate get vsize to y1
  185.  
  186.     // setup border segments
  187.     send initialize to (tb(current_object)) 1 y1
  188.     send initialize to (lb(current_object)) x1 1
  189.     send initialize to (rb(current_object)) x1 1
  190.     send initialize to (bb(current_object)) 1 y1
  191.  
  192.     // get size of desktop (ie. size of screen)
  193.     get size of desktop to complex
  194.     move (hi(complex)) to x2
  195.     move (low(complex)) to y2
  196.  
  197.     // calculate max row and column to prevent dragging past end of screen
  198.     set max_obj_row to (x2 - x1 - 1) // leave last row free for error msgs
  199.     set max_obj_col to (y2 - y1)
  200.   end_procedure
  201.  
  202.   // this activates the whole spiel
  203.   procedure popup
  204.     local integer x1 y1 x2 y2
  205.     local integer complex
  206.  
  207.     // get size of outermost object
  208.     delegate get hsize to x1
  209.     delegate get vsize to y1
  210.  
  211.     // get location of outermost object
  212.     get location of (parent(parent(current_object))) to complex
  213.     move (hi(complex)) to x2
  214.     move (low(complex)) to y2
  215.  
  216.     // set locations of all border segments
  217.     set location of (tb(current_object)) to x2 y2
  218.     set location of (lb(current_object)) to x2 y2
  219.     set location of (rb(current_object)) to x2 (y2 + y1 - 1)
  220.     set location of (bb(current_object)) to (x2 + x1 - 1) y2
  221.  
  222.     // find out where the mouse is
  223.     get absolute_mouse_location to complex
  224.  
  225.     // keep handy
  226.     set old_mouse_row to (hi(complex))
  227.     set old_mouse_col to (low(complex))
  228.  
  229.     // displays all borders; gives focus to first child (top border)
  230.     forward send popup
  231.   end_procedure
  232.  
  233.   // this drags all borders 
  234.   procedure drag_me
  235.     local integer complex
  236.     local integer old_row old_col
  237.     local integer new_row new_col
  238.     local integer inc_row inc_col
  239.     local integer obj_row obj_col
  240.     local integer max_row max_col
  241.  
  242.     // get location of top border (happens to be location of outermost
  243.     // object too!  Magic...)
  244.     get location of (tb(current_object)) to complex
  245.     move (hi(complex)) to obj_row
  246.     move (low(complex)) to obj_col
  247.  
  248.     // get move limits
  249.     get max_obj_row to max_row
  250.     get max_obj_col to max_col
  251.  
  252.     // where was the mouse before it was moved?
  253.     get old_mouse_row to old_row
  254.     get old_mouse_col to old_col
  255.  
  256.     // where is the mouse now?
  257.     get absolute_mouse_location to complex
  258.     move (hi(complex)) to new_row
  259.     move (low(complex)) to new_col
  260.  
  261.     // calculate relative moves
  262.     move (new_row - old_row) to inc_row
  263.     move (new_col - old_col) to inc_col
  264.  
  265.     // don't go outside of desktop...
  266.     if (obj_row + inc_row) lt 0 ;
  267.       move (0 - obj_row) to inc_row       // clamp to top edge
  268.  
  269.     if (obj_row + inc_row) gt max_row ;
  270.       move (max_row - obj_row) to inc_row // clamp to bottom edge
  271.  
  272.     if (obj_col + inc_col) lt 0 ;
  273.       move (0 - obj_col) to inc_col       // clamp to left edge
  274.  
  275.     if (obj_col + inc_col) gt max_col ;
  276.       move (max_col - obj_col) to inc_col // clamp to right edge
  277.  
  278.     // calculate new position
  279.     move (old_row + inc_row) to new_row
  280.     move (old_col + inc_col) to new_col
  281.  
  282.     // adjust mouse location if needed (ie. when clamped) & turn on mouse
  283.     set absolute_mouse_location to new_row new_col true
  284.  
  285.     // move all borders if possible
  286.     if (inc_row or inc_col) broadcast send relocate inc_row inc_col
  287.  
  288.     // remember current mouse location
  289.     set old_mouse_row to new_row
  290.     set old_mouse_col to new_col
  291.   end_procedure
  292.  
  293.   // this moves the outermost object to the final spot
  294.   procedure drop_me
  295.     local integer complex row col prow pcol
  296.  
  297.     // find out where the top border is at
  298.     get location of (tb(current_object)) to complex
  299.     move (hi(complex)) to row
  300.     move (low(complex)) to col
  301.  
  302.     // remove draggable borders from the screen
  303.     send deactivate
  304.  
  305.     // get location of outermost object's parent
  306.     get location of (parent(parent(parent(current_object)))) to complex
  307.     move (hi(complex)) to prow
  308.     move (low(complex)) to pcol
  309.  
  310.     // move outermost object to current spot, relative to its parent
  311.     set location of (parent(parent(current_object))) ;
  312.       to (row - prow) (col - pcol) relative
  313.   end_procedure
  314. end_class
  315.  
  316. // this is the button for the system menu
  317. class system_button is a button
  318.   procedure construct_object integer image
  319.     local integer complex
  320.  
  321.     forward send construct_object image
  322.  
  323.     set focus_mode to pointer_only
  324.  
  325.     get size of (parent(current_object)) to complex
  326.  
  327.     property integer hsize public (hi(complex))
  328.     property integer vsize public (low(complex))
  329.  
  330.     // include a draggable border
  331.     object rubberband is a rubberband no_image
  332.     end_object
  333.   end_procedure
  334.  
  335.   // sent by desktop; start dragging
  336.   procedure mouse_down2 integer win# integer pos#
  337.     forward send mouse_down2 win# pos#
  338.     send popup to (rubberband(current_object))
  339.   end_procedure
  340.  
  341.   // According to CUA: if you double-click on the system menu icon, then
  342.   // its parent should disappear (augment if necessary).
  343.   procedure mouse_click
  344.     send deactivate to (parent(current_object))
  345.   end_procedure
  346.  
  347.   // sent by parent; sends item message of item 0 in turn
  348.   procedure activate returns integer
  349.     local integer msg retval
  350.  
  351.     get message item 0 to msg
  352.     forward get msg to retval
  353.     procedure_return retval
  354.   end_procedure
  355.  
  356.   procedure mouse_down integer win# integer pos#
  357.     forward send mouse_down win# pos#
  358.     send mouse_up win# pos#
  359.   end_procedure
  360. end_class
  361.  
  362.  
  363.