모든 위젯에 툴팁 달기

아래의 커맨드로 위젯이 툴팁을 달 수 있습니다.

proc setTooltip {widget text} {
        if { $text != "" } {
                bind $widget <Any-Enter>    [list after 500 [list showTooltip %W $text]]
                bind $widget <Any-Leave>    [list after 500 [list destroy %W.tooltip]]
                bind $widget <Any-KeyPress> [list after 500 [list destroy %W.tooltip]]
                bind $widget <Any-Button>   [list after 500 [list destroy %W.tooltip]]
        }
}
proc showTooltip {widget text} {
        global tcl_platform

        if { [string match $widget* [winfo containing  \
                [winfo pointerx .] [winfo pointery .]] ] == 0  } {
                return
        }

        catch { destroy $widget.tooltip }

        set scrh [winfo screenheight $widget]    ; # 1) flashing window fix
        set scrw [winfo screenwidth $widget]     ; # 1) flashing window fix
        set tooltip [toplevel $widget.tooltip -bd 1 -bg black]
        wm geometry $tooltip +$scrh+$scrw        ; # 1) flashing window fix
        wm overrideredirect $tooltip 1

        if {$tcl_platform(platform) == {windows}} { ; # 3) wm attributes...
                wm attributes $tooltip -alpha 0.9
                wm attributes $tooltip -topmost 1   ; # 3) assumes...
        }                                           ; # 3) Windows
        pack [label $tooltip.label -bg lightyellow -fg black -text $text -justify left]

        set width [winfo reqwidth $tooltip.label]
        set height [winfo reqheight $tooltip.label]

        set positionX [winfo pointerx .]
        set positionY [expr [winfo pointery .] + 5]

        wm geometry $tooltip [join  "$width x $height + $positionX + $positionY" {}]
        raise $tooltip

        # 2) Kludge: defeat rare artifact by passing mouse over a tooltip to destroy it.
        bind $widget.tooltip <Any-Enter> {destroy %W}
        bind $widget.tooltip <Any-Leave> {destroy %W}
}

pack [button .b -text hello]
setTooltip .b "Hello World!"