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
Hide Diffs Unified Diffs 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
..
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
...
100
101
102
103
104
105
106














107
108
109
110
111
112
113
...
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


#
# 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 {}
}
................................................................................
# 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>
	    }
	}
    }

    #
................................................................................
    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 \
................................................................................
    }
}

#------------------------------------------------------------------------------
# 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} {








<
<







 







|
|
|
>
>

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



|
|
<
<


|
|




|


|


|
<







 







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







 







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








20
21
22
23
24
25
26


27
28
29
30
31
32
33
..
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
..
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
...
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569











570
571
572
573
574
575
576


#
# 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 {}
}
................................................................................
# 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>
	    }
	}
    }

    #
................................................................................
    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 \
................................................................................
    }
}

#------------------------------------------------------------------------------
# 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} {

This page was generated in about 0.007s by Fossil 2.7 [9aa9ba8bd2] 2018-09-22 17:40:11