#****
proc annotationConfig { c target } {
- global newoval $target
-
- set color [lindex [lsearch -inline [set $target] "color *"] 1]
- set label [lindex [lsearch -inline [set $target] "label *"] 1]
- set lcolor [lindex [lsearch -inline [set $target] "labelcolor *"] 1]
-
- # set newoval $target
switch -exact -- [nodeType $target] {
oval {
- popupOvalDialog $c $target "true" $color $label $lcolor
+ popupAnnotationDialog $c $target "true"
}
rectangle {
- popupRectDialog $c $target "true" $color $label $lcolor
+ popupAnnotationDialog $c $target "true"
}
text {
- textConfig $c $target
+ popupAnnotationDialog $c $target "true"
}
default {
puts "Unknown type [nodeType $target] for target $target"
# * lcolor -- label (text) color
#****
-proc popupOvalDialog { c target modify color label lcolor } {
- global newoval defOvalColor $target
-
-
- # do nothing, return, if coords are empty
- if { $target == 0 && [$c coords "$newoval"] == "" } {
- return
- }
- set wi .popup
- catch {destroy $wi}
- toplevel $wi
-
- wm transient $wi .
- wm resizable $wi 0 0
-
- if { $modify == "true" } {
- set windowtitle "Configure oval"
- } else {
- set windowtitle "Add a new oval"
- }
- wm title $wi $windowtitle
- frame $wi.lab -borderwidth 4
- label $wi.lab.name_label -text "Text for top of oval:"
- entry $wi.lab.name -bg white -width 16 \
- -validate focus -invcmd "focusAndFlash %W"
- $wi.lab.name insert 0 $label
- pack $wi.lab.name $wi.lab.name_label -side right -padx 4 -pady 4
- pack $wi.lab -side top
-
- # color selection controls
- frame $wi.colors -borderwidth 4
- label $wi.colors.label -text "Color:"
- if { $color == "" } {
- set color $defOvalColor
- }
- if { $lcolor == "" } {
- set lcolor black
- }
- label $wi.colors.color -text $color -width 8 \
- -bg $color -fg $lcolor
- button $wi.colors.fg -text "fg" -command \
- "popupColor fg $wi.colors.color false"
- button $wi.colors.bg -text "bg" -command \
- "popupColor bg $wi.colors.color true"
- pack $wi.colors.fg $wi.colors.bg $wi.colors.color $wi.colors.label \
- -side right -padx 4 -pady 4
- pack $wi.colors -side top
-
- set applycmd "popupOvalApply $c $wi $target"
-
- # Add new oval or modify old one?
- if { $modify == "true" } {
- set cancelcmd "destroy $wi"
- set applytext "Modify oval"
- } else {
- set cancelcmd "destroy $wi; destroyNewoval $c"
- set applytext "Add oval"
- }
- frame $wi.butt -borderwidth 6
- button $wi.butt.apply -text $applytext -command "$applycmd"
- button $wi.butt.cancel -text "Cancel" -command $cancelcmd
- bind $wi <Key-Escape> "$cancelcmd"
- bind $wi <Key-Return> "$applycmd"
- pack $wi.butt.cancel $wi.butt.apply -side right
- pack $wi.butt -side bottom
- after 100 {
- grab .popup
- }
- return
+proc adjustBkg { c wi } {
+ set color [$wi.colors.color cget -text]
+ $wi.border.color configure -bg $color
}
}
-# create a oval
-proc popupOvalApply { c wi target} {
- global newoval annotation_list
- global $target
- global changed
-
- # oval attributes
- set caption [string trim [$wi.lab.name get]]
- set color [$wi.colors.color cget -text]
- set labelcolor [$wi.colors.color cget -fg]
- set coords [$c coords "$target"]
- set iconcoords "iconcoords"
-
- # build the oval object
- if {$target == 0} {
- set object [newObjectId annotation]
- lappend annotation_list $object
- set coords [$c coords "$newoval"]
- } else {
- set object $target
- }
- global $object
- set $object {}
- lappend $iconcoords $coords
- lappend $object $iconcoords "color $color" \
- "label {$caption}" "labelcolor $labelcolor"
-
- # draw it
- drawOval $object
-
- destroyNewoval $c
- destroy $wi
- set changed 1
- updateUndoLog
- redrawAll
-}
-
-
# oval/rectangle/text right-click menu
proc button3annotation { type c x y } {
proc drawOval {oval} {
- global $oval defOvalColor defOvalLabelFont zoom curcanvas
+ global $oval defFillColor zoom curcanvas
+ global defTextFontFamily defTextFontSize
set coords [getNodeCoords $oval]
set x1 [expr {[lindex $coords 0] * $zoom}]
set color [lindex [lsearch -inline [set $oval] "color *"] 1]
set label [lindex [lsearch -inline [set $oval] "label *"] 1]
set lcolor [lindex [lsearch -inline [set $oval] "labelcolor *"] 1]
+ set bordercolor [lindex [lsearch -inline [set $oval] "border *"] 1]
+ set width [lindex [lsearch -inline [set $oval] "width *"] 1]
set lx [expr $x1 + (($x2 - $x1) / 2)]
set ly [expr ($y1 + 20)]
- if { $color == "" } {
- set color $defOvalColor
- }
- if { $lcolor == "" } {
- set lcolor black
- }
+ if { $color == "" } { set color $defFillColor }
+ if { $lcolor == "" } { set lcolor black }
+ if { $width == "" } { set width 1 }
+ if { $bordercolor == "" } { set bordercolor black }
+
# -outline red -stipple gray50
set newoval [.c create oval $x1 $y1 $x2 $y2 \
- -fill $color -width 2 -tags "oval $oval"]
+ -fill $color -width $width -outline $bordercolor -tags "oval $oval"]
.c raise $newoval background
+
+ set fontfamily [lindex [lsearch -inline [set $oval] "fontfamily *"] 1]
+ set fontsize [lindex [lsearch -inline [set $oval] "fontsize *"] 1]
+ if { $fontfamily == "" } {
+ set fontfamily $defTextFontFamily
+ }
+ if { $fontsize == "" } {
+ set fontsize $defTextFontSize
+ }
+ set newfontsize $fontsize
+ set font [list "$fontfamily" $fontsize]
+ set effects [lindex [lsearch -inline [set $oval] "effects *"] 1]
+
.c create text $lx $ly -tags "oval $oval" -text $label \
- -justify center -font $defOvalLabelFont -fill $lcolor
+ -justify center -font "$font $effects" -fill $lcolor
+
setNodeCanvas $oval $curcanvas
setType $oval "oval"
}
# * x0, y0 -- Coordinates of the upper left corner, in pixels
# * x3, y3 -- Coordinates of the lower right corner, in pixels
# * radius -- Radius of the bend at the corners, in any form
-# acceptable to Tk_GetPixels
+# acceptable to Tk_GetPixels
# * args -- Other args suitable to a 'polygon' item on the canvas
# Example:
# roundRect .c 100 50 500 250 $rad -fill white -outline black -tags rectangle
}
proc drawRect {rectangle} {
- global $rectangle defRectColor defRectLabelFont zoom curcanvas
+ global $rectangle defFillColor zoom curcanvas
+ global defTextFontFamily defTextFontSize
set coords [getNodeCoords $rectangle]
if {$coords == ""} {
set color [lindex [lsearch -inline [set $rectangle] "color *"] 1]
set label [lindex [lsearch -inline [set $rectangle] "label *"] 1]
set lcolor [lindex [lsearch -inline [set $rectangle] "labelcolor *"] 1]
+ set bordercolor [lindex [lsearch -inline [set $rectangle] "border *"] 1]
+ set width [lindex [lsearch -inline [set $rectangle] "width *"] 1]
+ set rad [lindex [lsearch -inline [set $rectangle] "rad *"] 1]
set lx [expr $x1 + (($x2 - $x1) / 2)]
set ly [expr ($y1 + 20)]
- if { $color == "" } {
- set color $defRectColor
- }
- if { $lcolor == "" } {
- set lcolor black
- }
+ if { $color == "" } { set color $defFillColor }
+ if { $lcolor == "" } { set lcolor black }
+ if { $bordercolor == "" } { set bordercolor black }
+ if { $width == "" } { set width 1 }
# rounded-rectangle radius
- set rad 25
+ if { $rad == "" } { set rad 25 }
+
set newrect [roundRect .c $x1 $y1 $x2 $y2 $rad \
- -fill $color -outline blue -tags "rectangle $rectangle"]
+ -fill $color -outline $bordercolor -width $width \
+ -tags "rectangle $rectangle"]
.c raise $newrect background
+
+ set fontfamily [lindex [lsearch -inline [set $rectangle] "fontfamily *"] 1]
+ set fontsize [lindex [lsearch -inline [set $rectangle] "fontsize *"] 1]
+ if { $fontfamily == "" } {
+ set fontfamily $defTextFontFamily
+ }
+ if { $fontsize == "" } {
+ set fontsize $defTextFontSize
+ }
+ set newfontsize $fontsize
+ set font [list "$fontfamily" $fontsize]
+ set effects [lindex [lsearch -inline [set $rectangle] "effects *"] 1]
+
.c create text $lx $ly -tags "rectangle $rectangle" -text $label \
- -justify center -font $defRectLabelFont -fill $lcolor
+ -justify center -font "$font $effects" -fill $lcolor
+
setNodeCanvas $rectangle $curcanvas
setType $rectangle "rectangle"
}
-proc popupRectDialog { c rectangle modify color label lcolor } {
- global newrect defRectColor
- global $rectangle
+proc popupAnnotationDialog { c target modify } {
+ global $target newrect newoval
+ global width rad fontfamily fontsize
+ global defFillColor defTextColor defTextFontFamily defTextFontSize
# do nothing, return, if coords are empty
- if { $rectangle == 0 && [$c coords "$newrect"] == "" } {
+ if { $target == 0 \
+ && [$c coords "$newrect"] == "" \
+ && [$c coords "$newoval"] == "" } {
return
}
+ if { $target == 0 } {
+ set width 1
+ set rad 25
+ set coords [$c bbox "$newrect"]
+ if { [$c coords "$newrect"] == "" } {
+ set coords [$c bbox "$newoval"]
+ set annotationType "oval"
+ } else {
+ set annotationType "rectangle"
+ }
+ set fontfamily ""
+ set fontsize ""
+ set effects ""
+ set color ""
+ set label ""
+ set lcolor ""
+ set bordercolor ""
+ } else {
+ set width [lindex [lsearch -inline [set $target] "width *"] 1]
+ set rad [lindex [lsearch -inline [set $target] "rad *"] 1]
+ set coords [$c bbox "$target"]
+ set color [lindex [lsearch -inline [set $target] "color *"] 1]
+ set fontfamily [lindex [lsearch -inline [set $target] "fontfamily *"] 1]
+ set fontsize [lindex [lsearch -inline [set $target] "fontsize *"] 1]
+ set effects [lindex [lsearch -inline [set $target] "effects *"] 1]
+
+ set label [lindex [lsearch -inline [set $target] "label *"] 1]
+ set lcolor [lindex [lsearch -inline [set $target] "labelcolor *"] 1]
+ set bordercolor [lindex [lsearch -inline [set $target] "border *"] 1]
+ set annotationType [nodeType $target]
+ }
+
+ if { $color == "" } { set color $defFillColor }
+ if { $lcolor == "" } { set lcolor black }
+ if { $bordercolor == "" } { set bordercolor black }
+ if { $width == "" } { set width 1 }
+ if { $rad == "" } { set rad 25 }
+ if { $fontfamily == "" } { set fontfamily $defTextFontFamily }
+ if { $fontsize == "" } { set fontsize $defTextFontSize }
+
+ set textBold 0
+ set textItalic 0
+ set textUnderline 0
+ if { [lsearch $effects bold ] != -1} {set textBold 1}
+ if { [lsearch $effects italic ] != -1} {set textItalic 1}
+ if { [lsearch $effects underline ] != -1} {set textUnderline 1}
+
+ set x1 [lindex $coords 0]
+ set y1 [lindex $coords 1]
+ set x2 [lindex $coords 2]
+ set y2 [lindex $coords 3]
+ set xx [expr {abs($x2 - $x1)}]
+ set yy [expr {abs($y2 - $y1)}]
+ if { $xx > $yy } {
+ set maxrad [expr $yy * 3.0 / 8.0]
+ } else {
+ set maxrad [expr $xx * 3.0 / 8.0]
+ }
+
set wi .popup
catch {destroy $wi}
toplevel $wi
wm resizable $wi 0 0
if { $modify == "true" } {
- set windowtitle "Configure rectangle $rectangle"
+ set windowtitle "Configure $annotationType $target"
} else {
- set windowtitle "Add a new rectangle"
+ set windowtitle "Add a new $annotationType"
}
wm title $wi $windowtitle
- frame $wi.lab -borderwidth 4
- label $wi.lab.name_label -text "Text for top of rectangle:"
- entry $wi.lab.name -bg white -width 16 \
+
+ frame $wi.text -relief groove -bd 2
+ frame $wi.text.lab
+ label $wi.text.lab.name_label -text "Text for top of $annotationType:"
+ entry $wi.text.lab.name -bg white -fg $lcolor -width 32 \
-validate focus -invcmd "focusAndFlash %W"
- $wi.lab.name insert 0 $label
- pack $wi.lab.name $wi.lab.name_label -side right -padx 4 -pady 4
- pack $wi.lab -side top
+ $wi.text.lab.name insert 0 $label
+ pack $wi.text.lab.name_label $wi.text.lab.name -side left -anchor w \
+ -padx 2 -pady 2 -fill x
+ pack $wi.text.lab -side top -fill x
- # color selection controls
- frame $wi.colors -borderwidth 4
- label $wi.colors.label -text "Color:"
+ frame $wi.text.format
+
+ set fontmenu [tk_optionMenu $wi.text.format.fontmenu fontfamily "$fontfamily"]
+ set sizemenu [tk_optionMenu $wi.text.format.fontsize fontsize "$fontsize"]
+
+
+ # color selection
if { $color == "" } {
- set color $defRectColor
+ set color $defTextColor
}
- if { $lcolor == "" } {
- set lcolor black
+ button $wi.text.format.fg -text "Text color" -command \
+ "popupColor fg $wi.text.lab.name false"
+ checkbutton $wi.text.format.bold -text "Bold" -variable textBold \
+ -command [list fontupdate $wi.text.lab.name bold]
+ checkbutton $wi.text.format.italic -text "Italic" -variable textItalic \
+ -command [list fontupdate $wi.text.lab.name italic]
+ checkbutton $wi.text.format.underline -text "Underline" \
+ -variable textUnderline \
+ -command [list fontupdate $wi.text.lab.name underline]
+
+ if {$textBold == 1} { $wi.text.format.bold select
+ } else { $wi.text.format.bold deselect }
+ if {$textItalic == 1} { $wi.text.format.italic select
+ } else { $wi.text.format.italic deselect }
+ if {$textUnderline == 1} { $wi.text.format.underline select
+ } else { $wi.text.format.underline deselect }
+
+ pack $wi.text.format.fontmenu \
+ $wi.text.format.fontsize \
+ $wi.text.format.fg \
+ $wi.text.format.bold \
+ $wi.text.format.italic \
+ $wi.text.format.underline \
+ -side left -pady 2
+
+ pack $wi.text.format -side top -fill x
+
+ pack $wi.text -side top -fill x
+
+ fontupdate $wi.text.lab.name fontfamily $fontfamily
+ fontupdate $wi.text.lab.name fontsize $fontsize
+
+ $fontmenu delete 0
+ foreach f [lsort -dictionary [font families]] {
+ $fontmenu add radiobutton -value "$f" -label $f \
+ -variable fontfamily \
+ -command [list fontupdate $wi.text.lab.name fontfamily $f]
+ }
+
+ $sizemenu delete 0
+ foreach f {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} {
+ $sizemenu add radiobutton -value "$f" -label $f \
+ -variable fontsize \
+ -command [list fontupdate $wi.text.lab.name fontsize $f]
}
+
+if { "$annotationType" == "rectangle" || "$annotationType" == "oval" } {
+
+ # fill color, border color
+ frame $wi.colors -relief groove -bd 2
+ # color selection controls
+ label $wi.colors.label -text "Fill color:"
+
label $wi.colors.color -text $color -width 8 \
-bg $color -fg $lcolor
- button $wi.colors.fg -text "fg" -command \
- "popupColor fg $wi.colors.color false"
- button $wi.colors.bg -text "bg" -command \
+ button $wi.colors.bg -text "Color" -command \
"popupColor bg $wi.colors.color true"
- pack $wi.colors.fg $wi.colors.bg $wi.colors.color $wi.colors.label \
- -side right -padx 4 -pady 4
- pack $wi.colors -side top
+ pack $wi.colors.label $wi.colors.color $wi.colors.bg \
+ -side left -padx 2 -pady 2 -anchor w -fill x
+ pack $wi.colors -side top -fill x
+
+ # border selection controls
+ frame $wi.border -relief groove -bd 2
+ label $wi.border.label -text "Border color:"
+ label $wi.border.color -text $bordercolor -width 8 \
+ -bg $color -fg $bordercolor
+ label $wi.border.width_label -text "Border width:"
+ set widthMenu [tk_optionMenu $wi.border.width width "$width"]
+ $widthMenu delete 0
+ foreach f {0 1 2 3 4 5 6 7 8 9 10} {
+ $widthMenu add radiobutton -value $f -label $f \
+ -variable width
+ }
+ button $wi.border.fg -text "Color" -command \
+ "popupColor fg $wi.border.color true"
+ pack $wi.border.label $wi.border.color $wi.border.fg \
+ $wi.border.width_label $wi.border.width \
+ $wi.border.fg $wi.border.color $wi.border.label \
+ -side left -padx 2 -pady 2 -anchor w -fill x
+ pack $wi.border -side top -fill x
+
+}
+
+if { $annotationType == "rectangle" } {
+ frame $wi.radius -relief groove -bd 2
+ scale $wi.radius.rad -from 0 -to [expr int($maxrad)] \
+ -length 400 -variable rad \
+ -orient horizontal -label "Radius of the bend at the corners: " \
+ -tickinterval [expr int($maxrad / 15) + 1] -showvalue true
+ pack $wi.radius.rad -side left -padx 2 -pady 2 -anchor w -fill x
+ pack $wi.radius -side top -fill x
+}
# Add new oval or modify old one?
if { $modify == "true" } {
set cancelcmd "destroy $wi"
- set applytext "Modify rectangle"
+ set applytext "Modify $annotationType"
} else {
set cancelcmd "destroy $wi; destroyNewRect $c"
- set applytext "Add rectangle"
+ set applytext "Add $annotationType"
}
frame $wi.butt -borderwidth 6
- button $wi.butt.apply -text $applytext \
- -command "popupRectApply $c $wi $rectangle"
+ button $wi.butt.apply -text $applytext -command "popupAnnotationApply $c $wi $target $annotationType"
button $wi.butt.cancel -text "Cancel" -command $cancelcmd
bind $wi <Key-Escape> "$cancelcmd"
- bind $wi <Key-Return> "popupRectApply $c $wi $rectangle"
+ bind $wi <Key-Return> "popupAnnotationApply $c $wi $target $annotationType"
pack $wi.butt.cancel $wi.butt.apply -side right
pack $wi.butt -side bottom
+
after 100 {
grab .popup
}
return
}
-
# helper for popupOvalDialog and popupOvalApply
proc destroyNewRect { c } {
global newrect
set newrect ""
}
-# create a rectangle
-proc popupRectApply { c wi target } {
- global newrect annotation_list
+
+proc popupAnnotationApply { c wi target type } {
+ global newrect newoval annotation_list
global $target
global changed
+ global width rad
+ global fontfamily fontsize textBold textItalic textUnderline
# attributes
- set caption [string trim [$wi.lab.name get]]
- set color [$wi.colors.color cget -text]
- set labelcolor [$wi.colors.color cget -fg]
+ set caption [string trim [$wi.text.lab.name get]]
+ set labelcolor [$wi.text.lab.name cget -fg]
set coords [$c coords "$target"]
set iconcoords "iconcoords"
- # build the oval object
- # Prije: set object [newObjectId annotation]
- set object $target
+ if {"$type" == "rectangle" || "$type" == "oval" } {
+ set color [$wi.colors.color cget -text]
+ set bordercolor [$wi.border.color cget -text]
+ }
+
if { $target == 0 } {
- # Create a new rectangle object
+ # Create a new annotation object
set target [newObjectId annotation]
global $target
lappend annotation_list $target
- set coords [$c coords $newrect]
+ if {"$type" == "rectangle" } {
+ set coords [$c coords $newrect]
+ } elseif { "$type" == "oval" } {
+ set coords [$c coords $newoval]
+ }
} else {
set coords [getNodeCoords $target]
}
set $target {}
lappend $iconcoords $coords
- lappend $target $iconcoords "color $color" \
- "label {$caption}" "labelcolor $labelcolor"
-
+ lappend $target $iconcoords "label {$caption}" "labelcolor $labelcolor" \
+ "fontfamily {$fontfamily}" "fontsize $fontsize"
+ if {"$type" == "rectangle" || "$type" == "oval" } {
+ lappend $target "color $color" "width $width" "border $bordercolor"
+ }
+ if {"$type" == "rectangle" } {
+ lappend $target "rad $rad"
+ }
+
+ set ef {}
+ if {"$textBold" == 1} { lappend ef bold}
+ if {"$textItalic" == 1} { lappend ef italic}
+ if {"$textUnderline" == 1} { lappend ef underline}
+ if {"$ef" != ""} { lappend $target "effects {$ef}"}
+
# draw it
- drawRect $target
- destroyNewRect $c
+ if { $type == "rectangle" } {
+ drawRect $target
+ destroyNewRect $c
+ } elseif { $type == "oval" } {
+ drawOval $target
+ destroyNewoval $c
+ } elseif { $type == "text" } {
+ drawText $target
+ }
set changed 1
updateUndoLog
setNodeCanvas $object $curcanvas
lappend annotation_list $object
- textConfig $c $object
+ popupAnnotationDialog $c $object "false"
}
}
set x [expr {[lindex $coords 0] * $zoom}]
set y [expr {[lindex $coords 1] * $zoom}]
- set color [lindex [lsearch -inline [set $text] "color *"] 1]
+ set color [lindex [lsearch -inline [set $text] "labelcolor *"] 1]
if { $color == "" } {
set color $defTextColor
}
}
-proc textConfig { c target } {
- global $target defTextColor defTextFont defTextFontFamily defTextFontSize
- global fontfamily fontsize
-
- set color [lindex [lsearch -inline [set $target] "color *"] 1]
- set label [lindex [lsearch -inline [set $target] "label *"] 1]
- set fontfamily [lindex [lsearch -inline [set $target] "fontfamily *"] 1]
- set fontsize [lindex [lsearch -inline [set $target] "fontsize *"] 1]
- set font [list "$fontfamily" $fontsize]
-
- set textBold 0
- set textItalic 0
- set textUnderline 0
- set effects [lindex [lsearch -inline [set $target] "effects *"] 1]
- if { [lsearch $effects bold ] != -1} {set textBold 1}
- if { [lsearch $effects italic ] != -1} {set textItalic 1}
- if { [lsearch $effects underline ] != -1} {set textUnderline 1}
-
- if { $fontfamily == "" } {
- set fontfamily $defTextFontFamily
- }
- if { $fontsize == "" } {
- set fontsize $defTextFontSize
- }
-
- set wi .popup
- catch {destroy $wi}
- toplevel $wi
-
- wm transient $wi .
- wm resizable $wi 1 1
- wm title $wi "Configure text"
-
- $wi configure -bd 2 -relief raised
-
- entry $wi.text -background white
- frame $wi.prop
- frame $wi.action
- pack $wi.text $wi.prop -anchor nw -side top -fill x
- pack $wi.action -side top
-
- frame $wi.prop.font -relief groove -bd 2
- label $wi.prop.font.label -text "Font:"
- set fontmenu [tk_optionMenu $wi.prop.font.menu fontfamily "$fontfamily"]
- set sizemenu [tk_optionMenu $wi.prop.font.size fontsize "$fontsize"]
-
- pack $wi.prop.font.label $wi.prop.font.menu \
- $wi.prop.font.size -side left -pady 2
-
- frame $wi.prop.format -relief groove -bd 2
- label $wi.prop.format.label -text "Effects:"
- pack $wi.prop.font $wi.prop.format -side top -pady 2 -anchor w -fill x
-
- # color selection
- if { $color == "" } {
- set color $defTextColor
- }
- button $wi.prop.format.fg -text "Color" -command \
- "popupColor fg $wi.text false"
- checkbutton $wi.prop.format.bold -text "Bold" -variable textBold \
- -command [list fontupdate $wi.text bold]
- checkbutton $wi.prop.format.italic -text "Italic" -variable textItalic \
- -command [list fontupdate $wi.text italic]
- checkbutton $wi.prop.format.underline -text "Underline" \
- -variable textUnderline \
- -command [list fontupdate $wi.text underline]
-
- if {$textBold == 1} {
- $wi.prop.format.bold select
- } else {
- $wi.prop.format.bold deselect
- }
- if {$textItalic == 1} {
- $wi.prop.format.italic select
- } else {
- $wi.prop.format.italic deselect
- }
- if {$textUnderline == 1} {
- $wi.prop.format.underline select
- } else {
- $wi.prop.format.underline deselect
- }
-
- pack $wi.prop.format.label \
- $wi.prop.format.fg \
- $wi.prop.format.bold \
- $wi.prop.format.italic \
- $wi.prop.format.underline \
- -side left -pady 2 ;# -fill both
-
- $wi.text insert end $label
- $wi.text configure -font [list "$fontfamily" $fontsize $effects] -fg $color
-
- $fontmenu delete 0
- foreach f [lsort -dictionary [font families]] {
- $fontmenu add radiobutton -value "$f" -label $f \
- -variable fontfamily \
- -command [list fontupdate $wi.text fontfamily $f]
- }
-
- $sizemenu delete 0
- foreach f {8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72} {
- $sizemenu add radiobutton -value "$f" -label $f \
- -variable fontsize \
- -command [list fontupdate $wi.text fontsize $f]
- }
-
- set applycmd "textConfigApply $c $wi $target "
- set cancelcmd "destroy $wi"
-
- button $wi.action.apply -text "Apply" -command "$applycmd"
- button $wi.action.cancel -text "Cancel" -command "$cancelcmd"
- bind $wi <Key-Escape> "$cancelcmd"
- bind $wi <Key-Return> "$applycmd"
-
- pack $wi.action.apply $wi.action.cancel -side left ;# -fill x
-
- after 100 {
- focus .popup.text
- grab .popup
- }
- return
-}
-
proc fontupdate { label type args} {
global fontfamily fontsize
global textBold textItalic textUnderline
}
-proc textConfigApply { c wi target } {
- global annotation_list
- global $target
- global fontfamily fontsize textBold textItalic textUnderline
- global changed
-
- # new text attributes
- set caption [string trim [$wi.text get]]
- # set color [$wi.prop.format.fg cget -fg]
- set color [$wi.text cget -fg]
- set iconcoords "iconcoords"
-
- # build the oval object
- if { $target == 0 } {
- # XXX what is the purpose of this?
- xxx xxx xxx
- set target [newObjectId "target"]
- global $target
- lappend annotation_list $target
- set coords [$c coords $newtext]
- } else {
- set coords [getNodeCoords $target]
- }
-
- set $target {}
- lappend $iconcoords $coords
- lappend $target $iconcoords "color $color" "label {$caption}"\
- "fontfamily {$fontfamily}" "fontsize $fontsize"
- set ef {}
- if {"$textBold" == 1} {
- lappend ef bold
- }
- if {"$textItalic" == 1} {
- lappend ef italic
- }
- if {"$textUnderline" == 1} {
- lappend ef underline
- }
- if {"$ef" != ""} {
- lappend $target "effects {$ef}"
- }
-
- # draw it
- drawText $target
- set changed 1
- updateUndoLog
- redrawAll
-
- destroy $wi
-}
-
# from Practical Programming in Tcl and Tk, page 190
proc Call_Trace {{file stdout}} {
puts $file "*** Tcl Call Trace:"
}
}
}
+
projects / imunes.git / commitdiff