#============================================================#
 # xybutton - Create button to perform "X" and "Y" scrolling. #
 #            Uses modified "button13" with repeat facility.  #
 #============================================================#
 
 #------------------------------------#
 # button13: Set-up "Button-13" event #
 #------------------------------------#
 
 proc button13 {widget {ms 200}} {
    bind $widget <Button-1> "button13proc1 $widget 1 $ms"
    bind $widget <ButtonRelease-1> "button13proc4"
    bind $widget <Button-3> "button13proc1 $widget 3 $ms"
    bind $widget <ButtonRelease-3> "button13proc4"
 }
 
 #----------------------------------------#
 # button13: Deal with mouse button press #
 #----------------------------------------#
 
 proc button13proc1 {widget button ms} {
    global button13
 
    set button13(down) 1
 
    if {[info exists button13($widget)] && ! [string equal $button13($widget) $button]} {
       event generate $widget <<Button-13>>
       catch "unset button13($widget)"
       return
    }
 
    set button13($widget) $button
 
    after $ms "button13proc2 $widget $button"
 }
 
 #-----------------------------------------------------------#
 # button13: Check if both buttons pressed within time limit #
 #-----------------------------------------------------------#
 
 proc button13proc2 {widget button} {
    global button13
 
    if {! [info exists button13($widget)]} {
       return
    }
 
    if {[info exists button13($widget)] && ! [string equal $button13($widget) $button]} {
       event generate $widget <<Button-13>>
    } else {
       if {$button13(down)} {set button13(startID) [after 500 "button13proc3 $widget $button"]}
       event generate $widget <<Button-$button>>
    }
 
    catch "unset button13($widget)"
 }
 
 #------------------------#
 # button13: Repeat event #
 #------------------------#
 
 proc button13proc3 {widget button} {
    global button13
 
    set button13(repeatID) [after 50 "event generate $widget <<Button-$button>>;button13proc3 $widget $button"]
 }
 
 #-------------------------#
 # button13: Cancel repeat #
 #-------------------------#
 
 proc button13proc4 {} {
    global button13
 
    set button13(down) 0
 
    if {[info exists button13(startID)]} {
       after cancel $button13(startID)
    }
    if {[info exists button13(repeatID)]} {
       after cancel $button13(repeatID)
    }
 }
 
 #-----------------------------#
 # xybutton: Create "xybutton" #
 #-----------------------------#
 
 proc xybutton {name target size {orient y}} {
    frame $name            -width $size -height $size -relief raised -borderwidth 1 
    frame $name.frame      -width $size -height $size
    frame $name.frame.line -width 4 -height 4 -relief raised -borderwidth 4
 
    grid propagate $name.frame 0
    grid $name.frame -sticky nsew
 
    grid columnconfigure $name.frame 0 -weight 1
    grid rowconfigure    $name.frame 0 -weight 1
 
    $name.frame      configure -background gray65
    $name.frame.line configure -relief raised
 
    if {[string equal $orient "y"]} {
       $name configure -cursor sb_h_double_arrow
    } else {
       $name configure -cursor sb_v_double_arrow
    }
 
    xybuttonToggle $name
 
    button13 $name
    button13 $name.frame
    button13 $name.frame.line
 
    bind $name            <<Button-1>>  "xybuttonScroll $name $target -1"
    bind $name.frame      <<Button-1>>  "xybuttonScroll $name $target -1"
    bind $name.frame.line <<Button-1>>  "xybuttonScroll $name $target -1"
    bind $name            <<Button-3>>  "xybuttonScroll $name $target  1"
    bind $name.frame      <<Button-3>>  "xybuttonScroll $name $target  1"
    bind $name.frame.line <<Button-3>>  "xybuttonScroll $name $target  1"
    bind $name            <<Button-13>> "xybuttonToggle $name"
    bind $name.frame      <<Button-13>> "xybuttonToggle $name"
    bind $name.frame.line <<Button-13>> "xybuttonToggle $name"
    bind $name             <Button-2>   "xybuttonToggle $name"
    bind $name.frame       <Button-2>   "xybuttonToggle $name"
    bind $name.frame.line  <Button-2>   "xybuttonToggle $name"
 }
 
 #-------------------------------------------------#
 # xybutton: Toggle between "X" and "Y" directions #
 #-------------------------------------------------#
 
 proc xybuttonToggle {name} {
    if {[string equal [$name cget -cursor] "sb_h_double_arrow"]} {
       grid $name.frame.line -sticky ns
       $name            configure -cursor sb_v_double_arrow
       $name.frame      configure -cursor sb_v_double_arrow
       $name.frame.line configure -cursor sb_v_double_arrow
    } else {
       grid $name.frame.line -sticky ew
       $name            configure -cursor sb_h_double_arrow
       $name.frame      configure -cursor sb_h_double_arrow
       $name.frame.line configure -cursor sb_h_double_arrow
    }
 }
 
 #--------------------------#
 # xybutton: Scroll command #
 #--------------------------#
 
 proc xybuttonScroll {name target direction} {
    if {[string equal [$name cget -cursor] "sb_v_double_arrow"]} {
       set orient yview
    } else {
       set orient xview
    }
 
    set scrollCommand "$target $orient scroll $direction unit"
 
    eval $scrollCommand
 }
 
 #==================#
 # Example of usage #
 #==================#
 
 frame     .frame      -relief groove -borderwidth 2
 text      .frame.text -width 20 -height 5 -wrap none -xscrollcommand ".frame.xbar set" -yscrollcommand ".frame.ybar set"
 scrollbar .frame.xbar -orient horizontal -command ".frame.text xview"
 scrollbar .frame.ybar -orient vertical   -command ".frame.text yview"
 xybutton  .frame.xyb .frame.text [.frame.xbar cget -width]
 
 
 grid .frame.text .frame.ybar -sticky nsew
 grid .frame.xbar .frame.xyb  -sticky nsew
 
 grid columnconfigure .frame 0 -weight 1
 grid rowconfigure    .frame 0 -weight 1
 
 pack .frame
 
 set TEXT "Now is the time for all good men
 to come to the aid of the party.
 
 The quick brown fox jumps over the
 lazy dog. Now is the time, yet again for all good men
 to come to the aid of the party.
 
 And this is, of course, more space filling rubbish.
 
 I could go on. I could go on and on. I could go on and on and...
 
 ...But that would be very boring indeed. I guess it is about time
 to wrap this up.
 
 THE END"
 
 .frame.text insert end $TEXT