convert to turn the code above to a PNG image.
namespace eval canvasexport {
namespace import ::tcl::mathop::* ::tcl::mathfunc::*
proc mvg canvas {
set col2hex {color {
if {[winfo exists $color] && [winfo class $color] eq "Canvas"} then {
set color [$color cget -bg]
}
if {$color eq ""} then {
set result none
} else {
set result #
foreach x [winfo rgb . $color] {
append result [format %02x [expr {int($x / 256)}]]
}
}
set result
}}
set splinecoords2mvg {{coords {canBeClosed yes}} {
set closed [expr {$canBeClosed &&
[lindex $coords 0] == [lindex $coords end-1] &&
[lindex $coords 1] == [lindex $coords end]}]
if {$closed} then {
lassign [lrange $coords end-3 end] x0 y0 x1 y1
set x [expr {($x0+$x1)/2.0}]
set y [expr {($y0+$y1)/2.0}]
lset coords end-1 $x
lset coords end $y
set coords [concat $x $y $coords]
}
if {[llength $coords] == 6} then {
lreplace $coords 2 1 Q
} else {
lappend result {*}[lrange $coords 0 1]
set co1 [lrange $coords 2 end-4]
set co2 [lrange $coords 4 end-2]
foreach {x1 y1} $co1 {x2 y2} $co2 {
lappend result $x1 $y1 [expr {($x1+$x2)/2.0}] [expr {($y1+$y2)/2.0}]
}
lappend result {*}[lrange $coords end-3 end]
lreplace $result 2 1 Q
}
}}
array set mode {fill ""
stroke ""
strokewidth ""
joinstyle ""
capstyle ""
fontfamily ""
fontsize ""}
lappend result [list viewbox 0 0 [winfo width $canvas] [winfo height $canvas]]
# lappend result [list stroke none]\
[list fill [apply $col2hex $canvas]]\
[list rectangle 0 0 [winfo width $canvas] [winfo height $canvas]]
foreach item [$canvas find all] {
if {[$canvas itemcget $item -state] eq "hidden"} continue
set type [$canvas type $item]
lappend result "# $type ... [$canvas gettags $item]"
# outline width
if {$type in {polygon oval arc rectangle line}} then {
set width [$canvas itemcget $item -width]
if {$width != $mode(strokewidth)} then {
set mode(strokewidth) $width
lappend result [list stroke-width $width]
}
}
# fill, stroke
if {$type in {polygon oval arc rectangle}} then {
set fill [apply $col2hex [$canvas itemcget $item -fill]]
if {$mode(fill) ne $fill} then {
set mode(fill) $fill
lappend result [list fill $fill]
}
set stroke [apply $col2hex [$canvas itemcget $item -outline]]
if {$mode(stroke) ne $stroke} then {
set mode(stroke) $stroke
lappend result [list stroke $stroke]
}
}
# joinstyle
if {$type in {polygon line}} then {
set joinstyle [$canvas itemcget $item -joinstyle]
if {$mode(joinstyle) ne $joinstyle} then {
set mode(joinstyle) $joinstyle
lappend result [list stroke-linejoin $joinstyle]
}
}
# line color, capstyle
if {$type in {line}} then {
if {$mode(fill) ne "none"} then {
set mode(fill) none
lappend result [list fill none]
}
set stroke [apply $col2hex [$canvas itemcget $item -fill]]
if {$mode(stroke) ne $stroke} then {
set mode(stroke) $stroke
lappend result [list stroke $stroke]
}
set capstyle [dict get {butt butt projecting square round round}\
[$canvas itemcget $item -capstyle]]
if {$mode(capstyle) ne $capstyle} then {
set mode(capstyle) $capstyle
lappend result [list stroke-linecap $capstyle]
}
}
# text color, font, size
if {$type in {text}} then {
if {$mode(stroke) ne "none"} then {
set mode(stroke) none
lappend result [list stroke none]
}
set fill [apply $col2hex [$canvas itemcget $item -fill]]
if {$mode(fill) ne $fill} then {
set mode(fill) $fill
lappend result [list fill $fill]
}
set font [$canvas itemcget $item -font]
# font-family, font-size
if {$font in font names} then {
set fontsize [font configure $font -size]
set fontfamily [font configure $font -family]
} else {
if {[llength $font] == 1} then {
set fontsize 12
} else {
set fontsize [lindex $font 1]
}
set fontfamily [lindex $font 0]
}
if {$fontsize < 0} then {
set fontsize [expr {int(-$fontsize / [tk scaling])}]
}
if {$mode(fontsize) ne $fontsize} then {
set mode(fontsize) $fontsize
lappend result [list font-size $fontsize]
}
#
# Attention! In some cases, IM assumes 72dpi,
# where 90dpi is necessary.
# Then, on cmd line, use switch -density as follows:
# convert -density 90 test.mvg test.png
#
if {$mode(fontfamily) ne $fontfamily} then {
set mode(fontfamily) $fontfamily
lappend result [list font $fontfamily]
}
#
# Attention! Care that IM has access to fonts.
# If not, an error msg is shown,
# then the default font is used silently.
#
}
set line {}
set coords [$canvas coords $item]
switch -exact -- $type {
line {
# start of path
lappend line path 'M
set smooth [$canvas itemcget $item -smooth]
if {[string is true -strict $smooth]} then {
if {[$canvas itemcget $item -arrow] eq "none"} then {
lappend line {*}[apply $splinecoords2mvg $coords]
} else {
lappend line {*}[apply $splinecoords2mvg $coords false]
}
} elseif {[string is false -strict $smooth]} then {
lappend line {*}[lrange $coords 0 1] L {*}[lrange $coords 2 end]
} else {
lappend line {*}[lrange $coords 0 1] C {*}[lrange $coords 2 end]
}
append line '
lappend result $line
}
polygon {
lappend line path 'M
set smooth [$canvas itemcget $item -smooth]
if {[string is false -strict $smooth]} then {
# line
lassign $coords x0 y0
lassign [lrange $coords end-1 end] x1 y1
set x [expr {($x0+$x1)/2.0}]
set y [expr {($y0+$y1)/2.0}]
lappend line $x $y L {*}$coords $x $y Z
} elseif {[string is true -strict $smooth]} then {
# spline
if {[lindex $coords 0] != [lindex $coords end-1] ||
[lindex $coords 1] != [lindex $coords end]} then {
lappend coords {*}[lrange $coords 0 1]
}
lappend line {*}[apply $splinecoords2mvg $coords]
} else {
# raw = bezier
lappend line {*}[lrange $coords 0 1]\
C {*}[lrange $coords 2 end] {*}[lrange $coords 0 1]
}
append line '
lappend result $line
}
oval {
lassign $coords x0 y0 x1 y1
lappend line ellipse [expr {($x0+$x1)/2.0}] [expr {($y0+$y1)/2.0}]\
[expr {$x1-($x0+$x1)/2.0}] [expr {$y1-($y0+$y1)/2.0}] 0 360
lappend result $line
}
arc {
lappend result [list push graphic-context]
lappend result [list stroke-linejoin miter]
# lappend result [list stroke-linejoin bevel]
# lappend result [list stroke-linejoin round]
lappend line path 'M
lassign $coords x0 y0 x1 y1
set rx [expr {($x1-$x0)/2.0}]
set ry [expr {($y1-$y0)/2.0}]
set x [expr {($x0+$x1)/2.0}]
set y [expr {($y0+$y1)/2.0}]
set f [expr {acos(0)/90}]
set start [$canvas itemcget $item -start]
set startx [expr {cos($start*$f)*$rx+$x}]
set starty [expr {sin(-$start*$f)*$ry+$y}]
set angle [expr {$start+[$canvas itemcget $item -extent]}]
set endx [expr {cos($angle*$f)*$rx+$x}]
set endy [expr {sin(-$angle*$f)*$ry+$y}]
# start point
lappend line\
[expr {($startx+$x)/2.0}] [expr {($starty+$y)/2.0}]\
$startx $starty
lappend line A
# radiusx, radiusy
lappend line $rx $ry
# angle -- always 0
lappend line 0
# "big" or "small"?
lappend line [expr {$angle-$start > 180}]
# right side (always)
lappend line 0
# end point
lappend line $endx $endy
# close path
lappend line L $x $y Z
append line '
lappend result $line
lappend result [list pop graphic-context]
}
rectangle {
lappend result\
[list push graphic-context]\
[list stroke-linejoin miter]\
[concat rectangle $coords]\
[list pop graphic-context]
}
text {
lassign [$canvas bbox $item] x0 y0 x1 y1
lappend line text $x0 $y1
append line " '[$canvas itemcget $item -text]'"
lappend result $line
}
image - bitmap {
set img [$canvas itemcget $item -image]
set file [$img cget -file]
lassign [$canvas bbox $item] x0 y0
lappend result [list image over $x0 $y0 0 0 '$file']
}
default {
lappend result "# not yet done:\
[$canvas type $item] [$canvas coords $item]\
([$canvas gettags $item])"
}
}
}
join $result \n
}
proc svg {{canvas .c} {title tk}} {
lappend result [subst {<svg xmlns="http://www.w3.org/2000/svg"\
width="[$canvas cget -width]px"\
height="[$canvas cget -height]px"\
viewbox="0 0 [$canvas cget -width] [$canvas cget -height]">}]
foreach item [$canvas find all] {
if {[$canvas itemcget $item -state] eq "hidden"} continue
if {[$canvas itemcget $item -fill] eq ""} continue
switch -exact -- [$canvas type $item] {
line {
lappend result [lineToSVG $item]
}
polygon {
lappend result [polyToSVG $item]
}
default {
lappend result "<!-- [$canvas type $item] not yet done -->"
}
}
}
string cat \n [join $result "\n "] \n </svg>
}
proc hex color {
lassign [winfo rgb . $color] r g b
string cat #\
[string range [format %04x $r] 0 1]\
[string range [format %04x $g] 0 1]\
[string range [format %04x $b] 0 1]
}
proc lineToSVG {item {canvas .c}} {
set coords [$canvas coords $item]
set style "fill:none;\
fill-rule:evenodd;\
stroke:[hex [$canvas itemcget $item -fill]];\
stroke-width:[$canvas itemcget $item -width]px;\
stroke-linecap:[$canvas itemcget $item -capstyle];\
stroke-linejoin:[$canvas itemcget $item -joinstyle];\
stroke-opacity:1"
set path [lmap {x y} $coords {string cat $x , $y}]
if {[$canvas itemcget $item -smooth] eq "raw"} then {
# bezier
while {[llength $path] % 3 != 1} {
# gemäß Canvas-Regeln für Bezier
lappend path [lindex $path end]
}
string cat <path\
" d=" \" "M [lindex $path 0] C [lrange $path 1 end]" \"\
" class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
" style=" \" $style \"\
" id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
" />"
} elseif {[$canvas itemcget $item -smooth]} then {
# spline
# not yet done
} else {
# straight
string cat <path\
" d=" \" "M $path" \"\
" class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
" style=" \" $style \"\
" id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
" />"
}
}
proc polyToSVG {item {canvas .c}} {
set coords [$canvas coords $item]
set style "fill:[hex [$canvas itemcget $item -fill]];\
fill-rule:evenodd;\
stroke:[$canvas itemcget $item -outline];\
stroke-width:[$canvas itemcget $item -width]px;\
stroke-linejoin:[$canvas itemcget $item -joinstyle];\
stroke-opacity:1"
set path [lmap {x y} $coords {string cat $x , $y}]
if {[$canvas itemcget $item -smooth] eq "raw"} then {
# bezier
while {[llength $path] % 3 != 0} {
# gemäß Canvas-Regeln für Bezier
lappend path [lindex $path end]
}
# gemäß SVG-Regeln für Bezier
lappend path [lindex $path 0]
#
string cat <path\
" d=" \" "M [lindex $path 0] C [lrange $path 1 end] Z" \"\
" class=" \" [concat [$canvas type $item] [$canvas gettags $item]] \"\
" style=" \" $style \"\
" id=" \" [$canvas type $item]-[$canvas find withtag $item] \"\
" />"
} elseif {[$canvas itemcget $item -smooth]} then {
# spline
# not yet done
} else {
# straight
# not yet done
}
}
namespace export svg mvg
namespace ensemble create
}
proc canvasToBitmap {{canvas .c} {file X:} {background white} args} {
variable externalApp
set ch [open tmp.mvg w]
puts $ch [canvasexport mvg $canvas]
close $ch
exec $externalApp(mvg)\
-size [$canvas cget -width]x[$canvas cget -height]\
xc:$background\
-draw @tmp.mvg\
$file {*}$args
}
© Wolf-Dieter Busch | Home | Sitemap | Urheber | A-Z