## jpeg file を扱う際にはこのライブラリが必要 #load "/Movie/xxx/bin/TkLib/libpife" package require Img set default_image_file "../default-naoko.jpg" ## 画像サイズの調整 (他所からの拾いもの) proc scaleImage {im xfactor {yfactor 0}} { if { $xfactor == 0 } { return; } if { $xfactor == 1 } { return; } set mode -subsample if {abs($xfactor) < 1} { set xfactor [expr round(1./$xfactor)] } elseif {$xfactor>=0 && $yfactor>=0} { set mode -zoom } set xfactor [expr round($xfactor)] if {$yfactor == 0} {set yfactor $xfactor} set t [image create photo] $t copy $im $im blank $im copy $t -shrink $mode $xfactor $yfactor image delete $t } proc scaleImage10 {im xfactor} { if { $xfactor <= 0 } { return; } if { $xfactor == 1 } { return; } set xfactz [expr round($xfactor * 10)] if { 1 < $xfactz } { set t [image create photo] $t copy $im $im blank $im copy $t -shrink -zoom $xfactz $xfactz } set tt [image create photo] $tt copy $im $im blank $im copy $tt -shrink -subsample 10 10 ## image delete $t image delete $tt } proc my_view { jpgf } { set winWidth 220 image create photo myjpeg -file "$jpgf" .jpeg configure -image myjpeg set jpgw [image width myjpeg] if { $jpgw < 1 } { set jpgw 1 } ;#div0 対策 set jpgw_scale [expr 1. * $winWidth / $jpgw] scaleImage10 myjpeg $jpgw_scale } label .lx pack .lx button .b -text "Quit" -command "exit" pack .b -in .lx -side right button .mx1 -text "larger" -command "scaleImage10 myjpeg 1.2" pack .mx1 -in .lx -side left button .mx2 -text "smaller" -command "scaleImage10 myjpeg 0.8" pack .mx2 -in .lx label .jpeg pack .jpeg my_view $default_image_file