JMeh 20 Dec 2017 - tblNaturalDrag
Implementation of a natural way of local drag and drop with automatic scrolling if the mouse cursor is above the first or last row in the tablelist or tablelist_tile widget, no matter which selection mode is active. All previous selected lines are collected into one block and inserted at the drop position. No mouse movement is required while scrolling, instead the speed of scrolling accelerates the longer the mouse cursor lingers over the first or last visible line. The actual drop position is shown by a horizontal line using the tablelist showtargetmark mechanism. At the end of the drag process a virtual <<Drop>> event is generated.
Bugs:
- Under Windows, it is not possible to bind Button-1 for dragging. The tablelist widget immediately activates single selection mode.
- Under macOS, the command hidetargetmark doesn't work. Multiple tergetmark lines are shown, possible a refresh error.
package provide tblNaturalDrag 0.1
##
# @brief this installs the natural local drag & drop mechanism for the tablelist widget
# @param tbl tablelist widget
# @param args options: -button, -cycle, -accel, -color
#
# Install the natural local drag & drop mechanism for the tablelist or tablelist_tile
# widget and configure it with the following options:
# - button specifies the button number (defaults to 1)
# - cycle specifies the time in milliseconds (defaults to 100) for calling the scroll procedure
# - accel sets the factor for acceleration (defaults to 1.0)
# - color sets the color of the target mark (defaults to green)
#
proc tblNaturalDrag {tbl args} {
global dragInfo
if {[info commands tablelist::tablelist] == {}} {
error "package tablelist or tablelist_tile required"
}
# init configurable drag infos
set dragInfo(button) 1
set dragInfo(cycle) 100
set dragInfo(accel) 1.0
set dragInfo(color) green
# set drag parameters
foreach {opt val} $args {
set item [string range $opt 1 end]
if {[info exists dragInfo($item)]} {
set dragInfo($item) $val
} else {
error "unknown option: $opt"
}
}
$tbl configure -targetcolor $dragInfo(color) -customdragsource true
set dragInfo(start) 0
set dragInfo(x) -1
set dragInfo(y) -1
set dragInfo(timer) {}
# start with mouse button down event
bind [$tbl bodytag] <ButtonPress-$dragInfo(button)> {_tblNaturalDragStart %W %x %y}
}
proc _tblNaturalDragStart {w x y} {
global dragInfo
# make window coordinates listbox relative
foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
# setup dragInfo array
set dragInfo(start) [clock milliseconds]
set dragInfo(x) $x
set dragInfo(y) $y
set dragInfo(row) -1
# start check timer for scrolling
set dragInfo(timer) [after $dragInfo(cycle) _tblNaturalDragCheck $tbl]
# update coordinates on mouse movement
bind [$tbl bodytag] <Motion> {_tblNaturalDragScan %W %x %y}
# end with release of mouse button
bind [$tbl bodytag] <ButtonRelease-$dragInfo(button)> {_tblNaturalDragDrop %W %x %y}
}
proc _tblNaturalDragCheck {tbl} {
global dragInfo
after cancel $dragInfo(timer)
set x $dragInfo(x)
set y $dragInfo(y)
set dragInfo(row) [$tbl containing $y]
$tbl showtargetmark before $dragInfo(row)
set topRow [$tbl index top]
set botRow [$tbl index bottom]
# calc scroll amount per time slot
set now [clock milliseconds]
set scrollCount [expr {int($dragInfo(accel) * ($now - $dragInfo(start)) / 1000.0 + 0.5)}]
if {$dragInfo(row) == $topRow} {
# scroll back n lines
$tbl yview scroll -$scrollCount units
} elseif {$dragInfo(row) == $botRow} {
# scroll forward n lines
$tbl yview scroll +$scrollCount units
} else {
# slow down if not in first or last row
set dragInfo(start) $now
}
set dragInfo(timer) [after $dragInfo(cycle) _tblNaturalDragCheck $tbl]
}
proc _tblNaturalDragScan {w x y} {
global dragInfo
# make window coordinates listbox relative
foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
# update mouse coordinates
set dragInfo(x) $x
set dragInfo(y) $y
}
proc _tblNaturalDragDrop {w x y} {
global dragInfo
# stop scrolling immediately
after cancel $dragInfo(timer)
# make window coordinates listbox relative
foreach {tbl x y} [tablelist::convEventFields $w $x $y] {}
# remove mouse motion binding
bind [$tbl bodytag] <Motion> {}
# hide drop marker line
$tbl hidetargetmark
# quit if no drop destination
if {$dragInfo(row) == -1} return
# get lines to move and quit if empty
set sel [$tbl curselection]
if {$sel == {}} return
# count number of lines above drop line
set upCnt 0
foreach row $sel {
if {$row < $dragInfo(row)} { incr upCnt } break
}
# get selected rows
set selData [$tbl get $sel]
set selCnt [llength $sel]
$tbl delete $sel
# calculate destination range
set insRow [expr {$dragInfo(row) - $upCnt}]
set lastRow [expr {$insRow + $selCnt -1}]
# reinsert data at this new position
if {$selCnt > 1} {
$tbl insertlist $insRow $selData
} else {
$tbl insert $insRow $selData
}
# reselect inserted rows
$tbl selection set $insRow $lastRow
$tbl activate $insRow
if {$insRow == $lastRow} {
event generate $tbl <<Drag>> -data $insRow
} else {
event generate $tbl <<Drag>> -data [list $insRow $lastRow]
}
}
if {[info exists argv0] && [file tail $argv0] == "tblNaturalDrag.tcl"} {
package require tablelist_tile
set tbl .t
set cols {
0 Name left
0 Value right
}
grid [tablelist::tablelist $tbl -columns $cols -height 20 \
-selectmode extended -yscrollcommand ".sby set"] -row 1 -column 0 -sticky nswe
grid [ttk::scrollbar .sby -orient vertical -command "$tbl yview"] \
-row 1 -column 1 -sticky ns
grid rowconfigure . 1 -weight 1
tblNaturalDrag $tbl -button 3 -cycle 50 -accel 2.5
proc dropDebugger {args} {puts "dropDebugger $args"}
bind $tbl <<Drag>> {dropDebugger %W %d}
set data {}
set n 1000
for {set i 0} {$i < $n} {incr i} {
lappend data [list "Test $i" $i]
}
$tbl insertlist end $data
}
