AuthorMessage
Meka][Meka
Unstopable
Posts: 700

Code:

proc ok {} {
  puts [getXLFD]
  exit
}
proc getXLFD {} {
  global bold italic fontsize
  set fstring ""
  set facename [.fontname get [.fontname curselection]]
  if {$bold} {
    set fstring "*-$facename-bold"
  } else {
    set fstring "*-$facename-medium"
  }
  if {$italic} {
    if {$facename == "Helvetica" || $facename == "Courier"} {
      set fstring "$fstring-o-normal--$fontsize-*"
    } else {
      set fstring "$fstring-i-normal--$fontsize-*"
    }
  } else {
    set fstring "$fstring-r-normal--$fontsize-*"
  }
  return $fstring
}
proc resetFont {} {
  .preview configure -font [getXLFD] 
}
proc changeSize y {
  global fontsize
  if [regexp {^[0-9]+$} $fontsize] {
    set fontsize [expr $fontsize-$y]
  }
  else {
    set fontsize 1
  }
}
proc help {} {
  puts "no built-in help support"
}
option add *font -adobe-helvetica-medium-r-normal--14-140-75-75-p-77-iso8859-1
wm geometry . 346x334
bind all <KeyPress-F1> help
label .namel -text "Name:"
place .namel -x 8 -y 4 -width 64 -height 32
listbox .fontname -relief sunken -yscrollcommand ".fnsb set"
scrollbar .fnsb -relief sunken -command ".fontname yview"
place .fontname -x 16 -y 36 -width 184 -height 140
place .fnsb -x 200 -y 36 -width 16 -height 140
foreach name {Charter Clean Courier Helvetica Lucida LucidaBright\
      LucidaTypewriter {New Century Schoolbook} Symbol Times\
      fixed terminal} {
    .fontname insert end $name
}
bind .fontname <ButtonRelease-1> resetFont
label .sizel -text "Size:"
place .sizel -x 224 -y 40 -width 48 -height 32
set fontsize 14
entry .fontsize -relief sunken -textvariable fontsize
place .fontsize -x 272 -y 40 -width 40 -height 32
scrollbar .sb -command changeSize
place .sb  -x 312 -y 36 -width 22 -height 40
label .stylel -text "Style:"
place .stylel -x 224 -y 104 -width 52 -height 32
set bold 0
set italic 0
checkbutton .bold -text "Bold" -variable bold -command resetFont
place .bold  -x 276 -y 104 -width 60 -height 28
checkbutton .italic -text "Italic" -variable italic -command resetFont
place .italic -x 276 -y 132 -width 60 -height 28
label .previewl -text "Preview:"
place .previewl  -x 12 -y 200 -width 76 -height 32
set previewtext "Sample text"
entry .preview -relief sunken -textvariable previewtext
place .preview -x 84 -y 200 -width 246 -height 72
button .ok -text "OK" -command ok
place .ok  -x 13 -y 288 -width 96 -height 36
button .cancel -text "Cancel" -command exit
place .cancel  -x 129 -y 288 -width 96 -height 36
button .help -text "Help" -command help
place .help -x 238 -y 288 -width 96 -height 36