NetNews Usenet Archive 1992 #31/NN_1992_31.iso/spool/comp/lang/tcl/2246

Text File | 1992-12-24 | 5.5 KB | 229 lines

Newsgroups: comp.lang.tcl
Path: sparky!uunet!timbuk.cray.com!hemlock.cray.com!mgc
From: [e-mail] (M. G. Christenson)
Subject: Re: Automatic Scrolling
Message-ID: <[e-mail]>
Lines: 217
Nntp-Posting-Host: pecan
Reply-To: [e-mail]
Organization: Cray Research, Inc.
Date: 24 Dec 92 01:14:40 CST

>Hi,
>
>I am trying to implement automatic scrolling for scrollable canvas.
>Instead of using the scroll bar, the canvas will be scrolling when
>the mouse pointer is outside of the canvas. (The canvas will scroll
>to the opposite direction of the location of the mouse pointer.)
>(This feature is great when you want to drag a widget across a
>scrollable canvas, so you can always see the widget at the edge
>of the canvas.)
>
>I have tried to implement this feature through bindings. However
>it does not work out nicely, since the events are not repeated.
>
>Has someone tried to accomplish similar task before?
>Any input would be appreciated.
>
>Te-Wei Sun
>[e-mail]

Here is the code I use, along with an example.  Hopefully the usage
will be apparent from the example.

--Mark

proc autoscroll_var w {
    global autoscroll_index

    if [info exists autoscroll_index($w)] {
    return autoscroll.$autoscroll_index($w)
    } else {
    if [info exists autoscroll_index(next)] {
        set next [expr {$autoscroll_index(next) + 1}]
    } else {
        set next 0
    }
    set autoscroll_index(next) $next
    return autoscroll.[set autoscroll_index($w) $next]
    }
}

proc autoscroll_init \
    {w delta_t {yscrollbar {}} {delta_y 1} {xscrollbar {}} {delta_x 1}} {
    upvar #0 [autoscroll_var $w] v

    if {$delta_t == 0} {
    catch {unset v}
    return {}
    }

    set v(autoscroll_delta_t) $delta_t
    set v(autoscroll_delta_x) $delta_x
    set v(autoscroll_delta_y) $delta_y

    set v(autoscroll_xscrollbar) $xscrollbar
    if {$xscrollbar == {}} {
    set v(autoscroll_dx) 0
    }
    set v(autoscroll_yscrollbar) $yscrollbar
    if {$yscrollbar == {}} {
    set v(autoscroll_dy) 0
    }

    if {[trace vinfo v(autoscroll_dx)] == {}} {
    set v(autoscrolling) 0
    set v(autoscroll_dx) 0
    set v(autoscroll_dy) 0

    trace variable v(autoscroll_dx) w "autoscroll $w"
    trace variable v(autoscroll_dy) w "autoscroll $w"
    }

    return {}
}

proc autoscroll_event {w x y event} {
    set cmd [bind $w $event]
    if {$cmd == {}} {
    set cmd [bind [winfo class $w] $event]
    }
    if {$cmd != {}} {
    regsub -all W $cmd $w cmd
    regsub -all 2bfa10 $cmd $x cmd
    regsub -all y $cmd $y cmd
    uplevel #0 $cmd
    }
}

proc autoscroll {w args} {
    upvar #0 [autoscroll_var $w] v

    if {$args == {}} {
    if $v(autoscroll_dx) {
        set current [lindex [$v(autoscroll_xscrollbar) get] 2]
        set cmd [lindex [$v(autoscroll_xscrollbar) config -command] 4]
        eval $cmd [expr "$current + $v(autoscroll_dx)"]
        if {$v(autoscroll_event) != {}} {
        autoscroll_event $w $v(autoscroll_x) $v(autoscroll_y) \
            $v(autoscroll_event)
        }
    }
    if $v(autoscroll_dy) {
        set current [lindex [$v(autoscroll_yscrollbar) get] 2]
        set cmd [lindex [$v(autoscroll_yscrollbar) config -command] 4]
        eval $cmd [expr "$current + $v(autoscroll_dy)"]
        if {$v(autoscroll_event) != {}} {
        autoscroll_event $w $v(autoscroll_x) $v(autoscroll_y) \
            $v(autoscroll_event)
        }
    }
    set v(autoscrolling) 0
    }

    if {$v(autoscroll_dx) || $v(autoscroll_dy)} {
    if !$v(autoscrolling) {
        set v(autoscrolling) 1
        after $v(autoscroll_delta_t) autoscroll $w
    }
    } else {
    set v(autoscrolling) 0
    }
}

proc clear_autoscroll {w} {
    upvar #0 [autoscroll_var $w] v

    if [info exists v] {
    set v(autoscroll_dx) 0
    set v(autoscroll_dy) 0
    }
    return {}
}

proc check_autoscroll {w x y {event {}}} {
    upvar #0 [autoscroll_var $w] v

    if ![info exists v] {
    return {}
    }

    set dx 0
    if {$v(autoscroll_xscrollbar) != {}} {
    if {$x < 0} {
        set dx -$v(autoscroll_delta_x)
    } else {
        if {$x >= [winfo width $w]} {
        set dx $v(autoscroll_delta_x)
        }
    }
    }

    set dy 0
    if {$v(autoscroll_yscrollbar) != {}} {
    if {$y < 0} {
        set dy -$v(autoscroll_delta_y)
    } else {
        if {$y >= [winfo height $w]} {
        set dy $v(autoscroll_delta_y)
        }
    }
    }

    set v(autoscroll_x) $x
    set v(autoscroll_y) $y
    set v(autoscroll_event) $event

    if {$v(autoscroll_dx) != $dx} {
    set v(autoscroll_dx) $dx
    }

    if {$v(autoscroll_dy) != $dy} {
    set v(autoscroll_dy) $dy
    }

    return {}
}

proc bind_for_autoscroll {{classes {Text Listbox Canvas Entry}}} {
    foreach class $classes {
    bind $class <B1-Motion> {+check_autoscroll W 2c03bd y <B1-Motion>}
    bind $class <Shift-B1-Motion> \
        {+check_autoscroll W 2c0426 y <Shift-B1-Motion>}
    bind $class <Any-ButtonRelease-1> {+clear_autoscroll W}
    }
}

proc autoscroll_example {} {
    catch {destroy .example}

    frame .example
    scrollbar .example.h -orient horizontal -command ".example.c xview"
    scrollbar .example.v -command ".example.c yview"
    canvas .example.c -confine 0 -xscrollcommand ".example.h set" \
    -yscrollcommand ".example.v set"

    bind .example.c <1> {set x [W canvasx 2c05e9]; set y [W canvasy y]}
    bind .example.c <B1-Motion> {
    W delete oval
    set xx  [W canvasx 2c066a]
    set yy  [W canvasy y]
    W create oval \
        $x $y $xx $yy -tag oval -fill red
    W config -scrollregion [W bbox withtag oval]
    }

    autoscroll_init .example.c 100 .example.v 1 .example.h 1

    bind_for_autoscroll .example.c

    pack append .example \
    .example.h {bottom fillx} \
    .example.c {left expand fill} \
    .example.v {left filly}

    pack append . .example {top expand fill}
}