Tk Library Source Code
Check-in [2d552bd381]
Not logged in
Core Home Documentation Tickets | Timeline Branches Tags Wiki Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment: * scripts/wheelEvent.tcl: Adapted the bindings to TIP 563, meaning that the mouse wheel now will scroll a horizontal or vertical scrollbar regardless of whether the "Shift" key is down or not.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 2d552bd38133b44efe7839fa729f48f8c0ee30872f90985beb63f9ed5c209ad7
User & Date: csaba 2020-06-23 09:57:37
Context
2020-06-23
09:58
* scripts/tclIndex: Newly generated. check-in: 439a75261e user: csaba tags: trunk
09:57
* scripts/wheelEvent.tcl: Adapted the bindings to TIP 563, meaning that the mouse wheel now will scroll a horizontal or vertical scrollbar regardless of whether the "Shift" key is down or not. check-in: 2d552bd381 user: csaba tags: trunk
09:56
* scripts/scrollarea.tcl: Added the read-only public variable "scrollutil::scalingpct" and set it to 100, 125, 150, 175, or 200, correspondig to the display's DPI scaling level. check-in: d47b54cd78 user: csaba tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to modules/scrollutil/scripts/wheelEvent.tcl.
︙︙
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35


#
# Namespace initialization
# ========================
#

namespace eval scrollutil {
    variable winSys [tk windowingsystem]

    #
    # The list of scrollable widget containers that are
    # registered for scrolling by the mouse wheel event
    # bindings created by the createWheelEventBindings command:
    #
    variable scrlWidgetContList {}
}








<
<








20
21
22
23
24
25
26


27
28
29
30
31
32
33


#
# Namespace initialization
# ========================
#

namespace eval scrollutil {


    #
    # The list of scrollable widget containers that are
    # registered for scrolling by the mouse wheel event
    # bindings created by the createWheelEventBindings command:
    #
    variable scrlWidgetContList {}
}
︙︙
46
47
48
49
50
51
52
53
54
55


56
57
58
59
60
61
62
63

64

65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106














107
108
109
110
111
112
113

# TScrollbar, WheeleventRedir, and WheeleventBreak, as well as <Destroy>
# bindings for the binding tags ScrlWidgetCont and WheeleventWidget.
#------------------------------------------------------------------------------
proc scrollutil::createBindings {} {
    variable winSys

    #
    # On the windowing systems win32 and x11 there are no built-in
    # mouse wheel event bindings for the binding tag Scrollbar
    # if the Tk version is earlier than 8.6 -- create them here


    #
    if {$winSys eq "win32" || $winSys eq "x11"} {
	set scrollByUnits [expr {
	    [llength [info commands ::tk::ScrollByUnits]] == 0 ?
	    "tkScrollByUnits" : "tk::ScrollByUnits"}]

	bind Scrollbar <MouseWheel> [format {
	    %s %%W v [expr {%%D >= 0 ? (-%%D) / 30 : (-(%%D) + 29) / 30}]

	} $scrollByUnits]

	bind Scrollbar <Shift-MouseWheel> [format {
	    %s %%W h [expr {%%D >= 0 ? (-%%D) / 30 : (-(%%D) + 29) / 30}]
	} $scrollByUnits]

	if {$winSys eq "x11"} {
	    bind Scrollbar <Button-4>	    [list $scrollByUnits %W v -5]
	    bind Scrollbar <Button-5>	    [list $scrollByUnits %W v  5]
	    bind Scrollbar <Shift-Button-4> [list $scrollByUnits %W h -5]
	    bind Scrollbar <Shift-Button-5> [list $scrollByUnits %W h  5]

	    if {[package vcompare $::tk_patchLevel "8.7a3"] >= 0} {
		bind Scrollbar <Button-6>   [list $scrollByUnits %W h -5]
		bind Scrollbar <Button-7>   [list $scrollByUnits %W h  5]
	    }
	}
    }

    set eventList [list <MouseWheel> <Shift-MouseWheel>]
    switch $winSys {
	aqua {
	    lappend eventList <Option-MouseWheel> <Shift-Option-MouseWheel>
	}
	x11 {
	    lappend eventList <Button-4> <Button-5> \
			      <Shift-Button-4> <Shift-Button-5>
	    if {[package vcompare $::tk_patchLevel "8.7a3"] >= 0} {
		lappend eventList <Button-6> <Button-7>
	    }
	}
    }

    #
    # Copy the mouse wheel event bindings of the widget
    # class Scrollbar to the binding tag TScrollbar
    #
    foreach event $eventList {
	bind TScrollbar $event [bind Scrollbar $event]
    }

    if {$winSys eq "win32" && [package vcompare $::tk_patchLevel "8.6b2"] < 0} {
	return ""
    }















    foreach event $eventList {
	if {[string match <*Button-?> $event]} {
	    bind WheeleventRedir $event [format {
		if {![scrollutil::hasFocus %%W] ||
		    ![scrollutil::isCompatible %s %%W]} {
		    event generate [winfo toplevel %%W] %s \








|
|
|
>
>

<
|
|
|
|
|
|
>
|
>
|
|



|
|
<
<


|
|




|


|


|
<

















>
>
>
>
>
>
>
>
>
>
>
>
>
>








44
45
46
47
48
49
50
51
52
53
54
55
56

57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72


73
74
75
76
77
78
79
80
81
82
83
84
85
86
87

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

# TScrollbar, WheeleventRedir, and WheeleventBreak, as well as <Destroy>
# bindings for the binding tags ScrlWidgetCont and WheeleventWidget.
#------------------------------------------------------------------------------
proc scrollutil::createBindings {} {
    variable winSys

    #
    # On the windowing systems win32 and x11 there are no built-in mouse wheel
    # event bindings for the binding tag Scrollbar if the Tk version is earlier
    # than 8.6 -- create them here.  In addition, implement the behavior
    # specified by TIP 563 (i.e., the mouse wheel should scroll a horizontal or
    # vertical scrollbar regardless of whether the "Shift" key is down or not)
    #

    set scrollByUnits [expr {
	[llength [info commands ::tk::ScrollByUnits]] == 0 ?
	"tkScrollByUnits" : "tk::ScrollByUnits"}]
    if {$winSys eq "aqua"} {
	bind Scrollbar <MouseWheel> \
	    [format {%s %%W hv [expr {-(%%D)}]} $scrollByUnits]
	bind Scrollbar <Option-MouseWheel> \
	    [format {%s %%W hv [expr {-10 * (%%D)}]} $scrollByUnits]
    } else {
	bind Scrollbar <MouseWheel> [format {
	    %s %%W hv [expr {%%D >= 0 ? (-%%D) / 30 : (-(%%D) + 29) / 30}]
	} $scrollByUnits]

	if {$winSys eq "x11"} {
	    bind Scrollbar <Button-4>	    [list $scrollByUnits %W hv -5]
	    bind Scrollbar <Button-5>	    [list $scrollByUnits %W hv  5]



	    if {[package vcompare $::tk_patchLevel "8.7a3"] >= 0} {
		bind Scrollbar <Button-6>   [list $scrollByUnits %W hv -5]
		bind Scrollbar <Button-7>   [list $scrollByUnits %W hv  5]
	    }
	}
    }

    set eventList [list <MouseWheel>]
    switch $winSys {
	aqua {
	    lappend eventList <Option-MouseWheel>
	}
	x11 {
	    lappend eventList <Button-4> <Button-5>

	    if {[package vcompare $::tk_patchLevel "8.7a3"] >= 0} {
		lappend eventList <Button-6> <Button-7>
	    }
	}
    }

    #
    # Copy the mouse wheel event bindings of the widget
    # class Scrollbar to the binding tag TScrollbar
    #
    foreach event $eventList {
	bind TScrollbar $event [bind Scrollbar $event]
    }

    if {$winSys eq "win32" && [package vcompare $::tk_patchLevel "8.6b2"] < 0} {
	return ""
    }

    #
    # The rest is for scrollable widget containers.
    #

    lappend eventList [list <Shift-MouseWheel>]
    switch $winSys {
	aqua {
	    lappend eventList <Shift-Option-MouseWheel>
	}
	x11 {
	    lappend eventList <Shift-Button-4> <Shift-Button-5>
	}
    }

    foreach event $eventList {
	if {[string match <*Button-?> $event]} {
	    bind WheeleventRedir $event [format {
		if {![scrollutil::hasFocus %%W] ||
		    ![scrollutil::isCompatible %s %%W]} {
		    event generate [winfo toplevel %%W] %s \
︙︙
543
544
545
546
547
548
549




550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571

    }
}

#------------------------------------------------------------------------------
# scrollutil::isCompatible
#------------------------------------------------------------------------------
proc scrollutil::isCompatible {event w} {




    set tagList [bindtags $w]
    set idx [lsearch -exact $tagList "WheeleventRedir"]
    set tag [lindex $tagList [incr idx]]
    if {[bind $tag $event] eq ""} {
	return 0
    } elseif {[string match "*Scrollbar" [winfo class $w]]} {
	set orient [$w cget -orient]
	return [expr {
	    ($orient eq "horizontal" &&  ([string match {<Shift-*>} $event] \
	     || [string match {<Button-[67]>} $event])) ||
	    ($orient eq "vertical"   && !([string match {<Shift-*>} $event] \
	     || [string match {<Button-[67]>} $event]))
	}]
    } else {
	return 1
    }
}

#------------------------------------------------------------------------------
# scrollutil::comparePaths
#------------------------------------------------------------------------------
proc scrollutil::comparePaths {w1 w2} {








>
>
>
>
|
|
|
<
<
<
<
|
<
<
<
<
<
<
<








555
556
557
558
559
560
561
562
563
564
565
566
567
568




569







570
571
572
573
574
575
576

    }
}

#------------------------------------------------------------------------------
# scrollutil::isCompatible
#------------------------------------------------------------------------------
proc scrollutil::isCompatible {event w} {
    if {[string match "*Scrollbar" [winfo class $w]] &&
	[string match {<Shift-*>} $event]} {
	return 1
    } else {
	set tagList [bindtags $w]
	set idx [lsearch -exact $tagList "WheeleventRedir"]
	set tag [lindex $tagList [incr idx]]




	return [expr {[bind $tag $event] ne ""}]







    }
}

#------------------------------------------------------------------------------
# scrollutil::comparePaths
#------------------------------------------------------------------------------
proc scrollutil::comparePaths {w1 w2} {
︙︙