Eskil

# addBalloon widget ?widgets...? ?-fmt? ?msg?
# If message is not given, it is extracted from widget. This is used to show
# e.g. labels where text might not be fully visible.
# Message may contain callbacks in [] for dynamic text.
proc psballoon::addBalloon {W args} {
    variable balloon
    variable config

    set frame $config(-useframe)

    # Last argument is message
    set msg [lindex $args end]

    set Wlist [list $W]
    foreach arg [lrange $args 0 end-1] {
        switch $arg {
            -fmt {
                # Request for formatting

                if {$msg ne ""} {
                    set msg [Fmt $msg]
                }
            }
            -frame {
                set frame 1
            }
            -top {
                set frame 0
            }
            default {
                lappend Wlist $arg
            }
        }
    }

    foreach W $Wlist {
        AddBalloon2 $W $msg $frame
    }
}

proc psballoon::AddBalloon2 {W msg frame} {
    variable balloon

    set c [winfo class $W]
    if {$msg == "" && $c != "Listbox" && $c != "Label"} {
        error "Missing message to balloon for $W ($c)"
    }
    set balloon(msg,$W) $msg
    set balloon(frame,$W) $frame
    bind $W <Enter> {
        set ::psballoon::balloon(pending) 1
        set ::psballoon::balloon(created) 0
        set ::psballoon::balloon(lastX) %X
        set ::psballoon::balloon(lastY) %Y
        set ::psballoon::balloon(id) [after 500 {psballoon::createBalloon %W %x %y}]
    }

    if {[catch {set font [$W cget -font]}]} {
        set font [ttk::style lookup [winfo class $W] -font]
    }
    # Fallback to something reasonable if font fails.
    if {$font eq ""} {
        set font TkDefaultFont
    }

    # Widget Geometry
    set wWidth [winfo width $W]
    set wHeight [winfo height $W]
    if {[winfo class $W] in {TLabelframe Labelframe}} {
        # Put it below the label, not the entire widget.
        # 1.5 font heights is a reasonable guess
        set fontHeight [font metrics $font -linespace]
        set wHeight [expr {$fontHeight * 3 /2 }]
        # Below cursor at least
        if {$wHeight <= $mouseY} {
            set wHeight [expr {$mouseY + 5}]
        }
    }

    # Item Geometry within Widget (if any)
    set itemX 0
    set itemY 0
    set create 1
    set msg $balloon(msg,$W)
    if {$msg == ""} {
        # Extract text from widget
        switch [winfo class $W] {
            Listbox {
                set i [$W index @$mouseX,$mouseY]
                set msg [$W get $i]
                foreach {itemX itemY itemWidth wHeight} [$W bbox $i] {break}
                set bWidth $itemWidth
            }
            Label {
                set msg [$W cget -text]
                set bWidth [Measure $font $msg]
            }
        }
        # Don't create a balloon if the text is fully visible.
        set create [expr {$bWidth > $wWidth - 8}]
    } else {
        if {[string index $msg 0] eq "\["} {
            set msg [subst -novariables -nobackslashes $msg]
        }
        set bWidth [Measure $font $msg]
    }

    if {!$create} return

    # Preferred position of the balloon
    set rootX [expr {[winfo rootx $W] + $itemX}]
    set rootY [expr {[winfo rooty $W] + $itemY + $wHeight + 2}]

    set useframe $balloon(frame,$W)

    if {$useframe} {
        set top [winfo toplevel $W]
        set posX [expr {$rootX - [winfo rootx $top]}]
        set posY [expr {$rootY - [winfo rooty $top]}]
        set minX 6
        set maxX [expr {[winfo width $top] - 6}]
    } else {
        set posX $rootX
        set posY $rootY

        # Limits of current screen.
        foreach {minX maxX} [FigureOutScreenWidths $W] {
            if {$minX <= $rootX && $rootX < $maxX} break
        }
    }
    # Move it to the left as needed to fit on screen
    if {$posX + $bWidth + 8 > $maxX} {
        set posX [expr {$maxX - $bWidth - 8}]
    }

    if {$useframe} {
        if {$top eq "."} {
            set B .balloon
        } else {
            set B $top.balloon
        }
        frame $B -borderwidth 1 -relief solid
    } else {
        set B .balloon
        toplevel $B -bg black
        wm overrideredirect $B 1
    }
    label $B.l \
            -text $msg -relief flat -font $font -justify left \
            -bg #ffffaa -fg black -padx 2 -pady 0 -anchor "w"
    pack $B.l -side left -padx 1 -pady 1
    if {$useframe} {
        place $B -x $posX -y $posY -anchor nw
    } else {
        wm geometry $B +${posX}+${posY}
    }
    set balloon(W) $B
    set balloon(created) 1

}