tku.tcl

genesis 2000 v9.1软件下载

#               MESSAGE - Message to display
#               FILE_PATH - A disk file to be displayed in scrolled text
#		ENTRY_VAR_P - A variable to be supplied by the user
# Output :	None 
# Return Value:	None
#
#*******************************************************
#
proc tku_popup_message {ICON TYPE MESSAGE {FILE_PATH ""} {ENTRY_VAR_P ""} } {
   global TKU_G
   
   upvar $ENTRY_VAR_P ENTRY_VAR
   set WF .popup_message
   append WF _ $TKU_G(WCOUNTER)
   incr TKU_G(WCOUNTER)
   set COLORS(error)    [list [c_black] [c_red]]
   set COLORS(warning)  [list [c_black] [c_eggyellow]]
   set COLORS(question) [list [c_black] [c_dblue]]
   set COLORS(info)     [list [c_black] [c_aqua]]
   
   set UPPER 1
   switch -- $TYPE {
      "abortretryignore" {
          set BUTTONS [list abort retry ignore]
      }
      "ok" {
          set BUTTONS [list ok]
      }
      "okcancel" {
          set BUTTONS [list ok cancel]
      }
      "retrycancel" {
          set BUTTONS [list retry cancel]
      }
      "yesno" {
          set BUTTONS [list yes no]
      }
      "yesnocancel" {
          set BUTTONS [list yes no cancel]
      }
      "yesnoshowmore" {
          set BUTTONS [list yes no "show more"]
      }
      default {
	  set BUTTONS $TYPE
	  set UPPER 0
      }
   }
   
   set FG [lindex $COLORS($ICON) 0] 
   set BG [lindex $COLORS($ICON) 1] 
   set WFL $WF.label
   set WFB $WF.button_frame
      
   toplevel $WF -bg $BG
   wm title $WF "Popup Message"
   label $WFL -fg $FG -bg $BG -font [cbr14] -text "$MESSAGE" \
              -relief groove -bd 5 -padx 30 -pady 30
   
   set WFF ""
   if { $FILE_PATH != "" } {
      set WFF $WF.file
      frame $WFF -bg $BG
      text $WFF.text -yscrollcommand "$WFF.scroll set" -setgrid 1 \
        -font [cbr14] -bg [c_yellow] -height 15   
      scrollbar $WFF.scroll -command "$WFF.text yview" -bg [c_yellow]
      pack $WFF.scroll -side right -fill y 
      pack $WFF.text -expand 1 -fill both
      if { ! [ catch {open $FILE_PATH} FP ] } {
	 set FILE_DATA [read $FP]
	 close $FP
         $WFF.text insert end $FILE_DATA    
      }
   }
   set WFE ""
   if { $ENTRY_VAR_P != "" } {
      set WFE $WF.entry
      set TKU_G(ENTRY_VAR) $ENTRY_VAR 
      entry $WFE -bg [c_yellow] -font [cbr14] \
           -textvariable TKU_G(ENTRY_VAR) -width 30
   }
   
   frame $WFB -bg $BG
   set I 0 
   foreach BUTTON $BUTTONS {
      set WB $WFB.button$I
      set STRING $BUTTON
      if { $UPPER } {
	 set STRING [string toupper $BUTTON]
      }
      button $WB -text $STRING -bg [c_aqua] -font [tbr18] \
             -highlightbackground $BG \
             -command [list tku.popup_message_cb $WF $BUTTON]
      pack $WB -side left -expand 1
      incr I
   }
   pack $WFL -fill x -padx 10 -pady 10
   if { $WFF != "" } {
      pack $WFF -fill x -padx 10 -pady 10
   }
   if { $WFE != "" } {
      pack $WFE -fill x -padx 10 -pady 10
   }
   pack $WFB -fill x -padx 10 -pady 10
   set TKU_G(MESSAGE_RES) ""
   wm transient $WF .
   tku_center_on_window . $WF 
   wm deiconify $WF
   focus $WF
   set TKU_G(GRAB_CURRENT) [grab current $WF]
   catch {grab $WF}
   tkwait window $WF
   if { [string length $TKU_G(MESSAGE_RES)] == 0 } {
      bgerror "Illegal popup destruction"
   }
   if { $WFE != "" } {
      set ENTRY_VAR $TKU_G(ENTRY_VAR) 
   }
   
   return $TKU_G(MESSAGE_RES)
}

proc tku.popup_message_cb {WF BUTTON} {
   global TKU_G
   
   set TKU_G(MESSAGE_RES) $BUTTON
   destroy $WF
   update
   grab release $WF
   if { [string length $TKU_G(GRAB_CURRENT)] != 0 } {
      grab set $TKU_G(GRAB_CURRENT)
   }
}


################ SCROLLED LISTS #########################
proc tku_scrolled_listbox { W ARGS_LIST ARGS_SB } {
   frame $W
   listbox $W.list \
     -xscrollcommand [list tku.scroll_set $W.xscroll \
        [list grid $W.xscroll -row 1 -column 0  -sticky we]] \
     -yscrollcommand [list tku.scroll_set $W.yscroll \
        [list grid $W.yscroll -row 0 -column 1 -sticky ns]]
   eval {$W.list configure} $ARGS_LIST
   
   scrollbar $W.xscroll -orient horizontal \
      -command [list $W.list xview]
   eval {$W.xscroll configure} $ARGS_SB
   
   scrollbar $W.yscroll  -orient vertical \
      -command [list $W.list yview]
   eval {$W.yscroll configure} $ARGS_SB
   
   grid $W.list $W.yscroll -sticky news
   grid $W.xscroll -sticky news
   grid rowconfigure $W 0 -weight 1
   grid columnconfigure $W 0 -weight 1
   return  $W.list 
}

proc tku.scroll_set { SCROLLBAR GEOCMD OFFSET SIZE } {
   if { $OFFSET != 0.0 || $SIZE != 1.0 } {
     eval $GEOCMD
     $SCROLLBAR set $OFFSET $SIZE
   } else {
     set MANAGER [lindex $GEOCMD 0]
     $MANAGER forget $SCROLLBAR 
   }
}
################  CURSORS #############################
proc tku_cursor_watch {} {
   . configure -cursor watch
   update idletasks
}

proc tku_cursor_normal {} {
   . configure -cursor left_ptr
   update idletasks
}
################  GEOMETRY #############################
#*******************************************************
#
# Name :	tku_center
#
# Description :	
#   Gets the center of a window and format it into a geometry string
#
# Input	:	toplevel window
#               XOFFSET - value to subtract from xcenter
#               YOFFSET - value to subtract from ycenter
# Output :	None
# Return Value:	+x+y
#
#*******************************************************
#
proc tku_center {W {XOFFSET 0} {YOFFSET 0}} {
  set GEOM [wm geometry $W]
  scan $GEOM "%dx%d+%d+%d" W H X Y
  set CX [expr $X+$W/2-$XOFFSET] 
  set CY [expr $Y+$H/2-$YOFFSET]
  return "+$CX+$CY"
}

#*******************************************************
#
# Name :	tku_center_on_window
#
# Description :	
#   Position window W2 exactly at the center of window W1
#
# Input	:	toplevel window
#               XOFFSET - value to subtract from xcenter
#               YOFFSET - value to subtract from ycenter
# Output :	None
# Return Value:	+x+y
#
#*******************************************************
#
proc tku_center_on_window {W1 W2} {
  set GEOM [wm geometry $W1]
  scan $GEOM "%dx%d+%d+%d" W H X Y
  set CX [expr $X+$W/2-200] 
  set CY [expr $Y+$H/2-200]
  set CENTER "+$CX+$CY"
  wm geometry $W2 $CENTER
  tkwait visibility $W2
  
  set WIDTH  [winfo width $W2]
  set HEIGHT [winfo height $W2]
  
  set XOFFSET [expr $WIDTH/2 -$W/2]
  set YOFFSET [expr $HEIGHT/2-$H/2]
  
  if { $XOFFSET > $X } {
     set XOFFSET $X
  }
  if { $YOFFSET > $Y } {
     set YOFFSET $Y
  }
  set CX [expr $X-$XOFFSET] 
  set CY [expr $Y-$YOFFSET]
  set CENTER "+$CX+$CY"
  wm geometry $W2 $CENTER
  wm deiconify $W2
  return $CENTER
}

################  COLOR #############################
#*******************************************************
#
# Name :	tku_color
#
# Description :	
#   Converts rrggbb to Tk color scheme
#
# Input	:	rrggbb
# Output :	None
# Return Value:	Tk Color
#
#*******************************************************
#
proc tku_color {RGB} {
  set R [expr $RGB/10000]
  set G [expr ($RGB - $R*10000)/100]
  set B [expr $RGB % 100]

  set R [expr $R*256/99]
  set R [ expr $R < 255 ? $R : 255 ]
  set G [expr $G*256/99]
  set G [ expr $G < 255 ? $G : 255 ]
  set B [expr $B*256/99]
  set B [ expr $B < 255 ? $B : 255 ]

  set COLOR [format "#%02x%02x%02x" $R $G $B]
  return $COLOR
}

proc c_white     {} {tku_color 999999}
proc c_black     {} {tku_color 000000}
proc c_gray      {} {tku_color 707070}
proc c_lblue     {} {tku_color 709999}
proc c_dblue     {} {tku_color 608585}
proc c_aqua      {} {tku_color 328068}
proc c_yellow    {} {tku_color 999980}
proc c_red       {} {tku_color 992020}
proc c_eggyellow {} {tku_color 987730}
proc c_mviolet   {} {tku_color 706080}

##############  FONT ##############################
#*******************************************************
#
# Name :	tku_font
#
# Description :	
#   Converts the font in xyznn to Tk 8.0 standard font
#
# Input	:	FN - xyznn
#               UNDERLINE - u for underlining
# Output :	None
# Return Value:	Tk standard font {type size {styles}}
#
#*******************************************************
#

proc tku_font {FN {UNDERLINE n}} {
  tk scaling 1
  set TYPE   [string index $FN 0]
  set BOLD   [string index $FN 1]
  set ITALIC [string index $FN 2]
  set SIZE   [string range $FN 3 4]

  set FTYPE   courier
  set FBOLD   bold
  set FITALIC regular
  set FUNDERLINE ""
  switch -- $TYPE {
    t { set FTYPE times }
    h { set FTYPE helvetica }
    c { set FTYPE courier }
  }
  switch -- $BOLD {
    b { set FBOLD bold }
    m { set FBOLD normal }
  }
  switch -- $ITALIC {
    r { set FITALIC roman }
    i { set FITALIC italic }
  }
  set STYLE [list $FBOLD $FITALIC]
  if { $UNDERLINE == "u" } {
     lappend STYLE underline
  }

  set FONT [list $FTYPE $SIZE $STYLE]
  return $FONT
}

proc tbr14 {} {return [tku_font tbr14]}
proc tbr18 {} {return [tku_font tbr18]}
proc tbr24 {} {return [tku_font tbr24]}

proc tbi14 {} {return [tku_font tbi14]}
proc tbi18 {} {return [tku_font tbi18]}
proc tbi24 {} {return [tku_font tbi24]}

proc tmr14 {} {return [tku_font tmr14]}
proc tmr18 {} {return [tku_font tmr18]}
proc tmr24 {} {return [tku_font tmr24]}

proc tmi14 {} {return [tku_font tmi14]}
proc tmi18 {} {return [tku_font tmi18]}
proc tmi24 {} {return [tku_font tmi24]}

proc cbr14 {} {return [tku_font cbr14]}
proc cbr18 {} {return [tku_font cbr18]}
proc cbr24 {} {return [tku_font cbr24]}

proc cbi14 {} {return [tku_font cbi14]}
proc cbi18 {} {return [tku_font cbi18]}
proc cbi24 {} {return [tku_font cbi24]}

proc cmr14 {} {return [tku_font cmr14]}
proc cmr18 {} {return [tku_font cmr18]}
proc cmr24 {} {return [tku_font cmr24]}

proc cmi14 {} {return [tku_font cmi14]}
proc cmi18 {} {return [tku_font cmi18]}
proc cmi24 {} {return [tku_font cmi24]}

proc hbr14 {} {return [tku_font hbr14]}
proc hbr18 {} {return [tku_font hbr18]}
proc hbr24 {} {return [tku_font hbr24]}

proc hbi14 {} {return [tku_font hbi14]}
proc hbi18 {} {return [tku_font hbi18]}
proc hbi24 {} {return [tku_font hbi24]}

proc hmr14 {} {return [tku_font hmr14]}
proc hmr18 {} {return [tku_font hmr18]}
proc hmr24 {} {return [tku_font hmr24]}

proc hmi14 {} {return [tku_font hmi14]}
proc hmi18 {} {return [tku_font hmi18]}
proc hmi24 {} {return [tku_font hmi24]}