Question

我想在画布小部件中关联缩放和滚动，中间的行（标记=中间）不应该像另一个那样移动，我找不到合适的方法来计算比率。请与我一起看看功能cvsZoom。

package require Tk


proc cvsZoom {cvs factor} {
puts "cvsZoom $factor"

set xlength [winfo width $cvs];
set ylength [winfo height $cvs]

set Xcenter [$cvs canvasx [expr {$xlength/2.0}]]
set Ycenter [$cvs canvasy [expr {$ylength/2.0}]]

$cvs scale all 0 0 $factor $factor

set Xcenter [expr {double($Xcenter * $factor)}]
set Ycenter [expr {double($Ycenter * $factor)}]
puts "  -- Xcenter $Xcenter, Ycenter $Ycenter"


# calculate bounding box 
set ix1 0; set ix2 0 ;
set iy1 0; set iy2 0 ;
foreach item [$cvs find all] {
    set coords  [$cvs coords $item]
    set tt      [lindex [$cvs gettags $item] 0]
    puts "  -- items coords $tt ::    $coords"
    foreach {x y} $coords {                    
        if { $x < $ix1 } {set ix1 $x}
        if { $x > $ix2 } {set ix2 $x}
        if { $y < $iy1 } {set iy1 $y}
        if { $y > $iy1 } {set iy2 $y}                    
    }
}
puts "  -- ix1 iy1 ix2 iy2 ::   $ix1 $iy1 $ix2 $iy2" 

# calculate x and y scrollregion
foreach {sx1 sy1 sx2 sy2} [$cvs cget -scrollregion] break
set xregion [expr {$sx2-$sx1}]
set yregion [expr {$sy2-$sy1}]
puts "  -- xregion $xregion, yregion $yregion"

# calculate x and y ratio !!!!!!!!!!!!!!!!!
set xratio  [expr {$ix2/$xregion}]
set yratio  [expr {$iy2/$yregion}]
puts "  -- xratio $xratio, yratio $yratio"

$cvs xview moveto $xratio
$cvs yview moveto $yratio

}
frame .fr -width 1000      -height 500
set cvs [canvas .fr.cv  -width 1000      -height 500 -xscrollcommand [list .fr.xscroll set]  \
 -yscrollcommand [list .fr.yscroll set] -background white    \
 -highlightthickness 0 -borderwidth 0  -scrollregion {0 0 1000 500}]

ttk::scrollbar .fr.xscroll -orient horizontal   -command "$cvs xview"
ttk::scrollbar .fr.yscroll -orient vertical     -command "$cvs yview"

bind .fr.xscroll <ButtonPress-1> "focus .fr.cv"
bind .fr.yscroll <ButtonPress-1> "focus .fr.cv"

grid .fr.cv .fr.yscroll -sticky news
grid .fr.xscroll -sticky ew
grid rowconfigure       .fr 0 -weight 1
grid columnconfigure    .fr 0 -weight 1

frame .fr.zomm 
button .fr.zomm.zoomin  -text "+"   -command "cvsZoom $cvs 1.1" 
button .fr.zomm.zoomout -text "-"   -command "cvsZoom $cvs 0.9"

grid .fr.zomm.zoomin  -row 0 -column 0
grid .fr.zomm.zoomout -row 0 -column 1
grid .fr.zomm


focus $cvs
pack  .fr -fill both -expand yes

set m_newytop 1

$cvs create line 0 230 1000 230 -tags top   -width 1 -fill black
$cvs create line 0 250 1000 250 -tags middle -width 1 -fill red
$cvs create line 0 270 1000 270 -tags bottom -width 1 -fill black

Answer 1

我找到了这个例子：Canvas Zooming。

我试着简化它，如下所示，它似乎几乎可以工作，中心点正在弹跳。在我添加一些垂直线之前，y-scroll没有做任何事情 - 可能还有其他问题。

  set winxlength [winfo width $cvs];
  set winylength [winfo height $cvs]

  lassign [$cvs bbox all] x1 y1 x2 y2
  set xlength [expr {$x2-$x1}]
  set ylength [expr {$y2-$y1}]

  set Xcenter [expr {[$cvs canvasx [expr {$xlength/2.0}]]*$factor}]
  set Ycenter [expr {[$cvs canvasy [expr {$ylength/2.0}]]*$factor}]

  $cvs scale all 0 0 $factor $factor

  set newxleft [expr {($Xcenter-$x1-($winxlength/2.0))/$xlength}]
  set newytop  [expr {($Ycenter-$y1-($winylength/2.0))/$ylength}]

  $cvs configure -scrollregion [list $x1 $y1 $x2 $y2]
  $cvs xview moveto $newxleft
  $cvs yview moveto $newytop
  $cvs configure -scrollregion [$cvs bbox all]

滚动比帆布tcl

1 个答案: