본문으로 바로가기

Topmost 1.0

category Tcl & Tk/확장 패키지 (Extension Package) 2025. 6. 19. 09:40

홈페이지: ???

 

Topmost forces a toplevel on top of all others on a display.

 

toplevel을 다른 모든 윈도우의 최상위에 표시하게 해주는 패키지입니다. 윈도우즈 전용입니다.

package require topmost
set top .top

wm withdraw .

toplevel $top
wm transient $top .
wm protocol $top WM_DELETE_WINDOW exit
wm withdraw $top

if [llength $argv] {
    set msg [join $argv]
} else {
    set msg "I like it on top!"
}

button $top.but -text $msg \
    -font {Script 72 bold italic} \
    -command exit
$top.but config -fg [$top.but cget -bg]
pack $top.but -fill both

button $top.changeon -text "topmost  ON" -command "topmost $top on"
button $top.changeoff -text "topmost OFF" -command "topmost $top off"
pack $top.changeon $top.changeoff -fill x

wm withdraw $top
update idletasks
set x [expr [winfo screenwidth $top]/2 - [winfo width $top]/2 \
    - [winfo vrootx [winfo parent $top]]]
set y [expr [winfo screenheight $top]/2 - [winfo height $top]/2 \
    - [winfo vrooty [winfo parent $top]]]
wm geom $top +$x+$y
wm resizable $top 0 0
update idletasks
wm deiconify $top
topmost $top on
pack propagate $top 0
update idletasks

$top.but config -text "" -fg darkred

proc tickertape {w string delay {pos -1} {wrap 0}} {
    if {$pos == -1} {
	append string "    ......   "
	$w config -anchor e
	tickertape $w $string $delay 0
    } else {
	set len [string length $string]
	if !$wrap {
	    $w config -text [string range $string 0 $pos]
	    if {[incr pos] < $len} {
		after $delay [list tickertape $w $string $delay $pos]
	    } else {
		after $delay [list tickertape $w $string $delay 0 1]
	    }
	} else {
	    $w config -text $string[string range $string 0 $pos]
	    if {[incr pos] < $len} {
		after $delay [list tickertape $w $string $delay $pos 1]
	    } else {
		after $delay [list tickertape $w $string $delay 0 1]
	    }
	}
    }
}

tickertape $top.but $msg 150

proc colourchange {w col} {
    $w config -fg #[format %03x $col]
    after 50 "colourchange $w [expr {($col + 1) & 0xfff}]"
}

colourchange $top.but 0

topmost-1.0.tar.gz
0.01MB

 

 

'Tcl & Tk > 확장 패키지 (Extension Package)' 카테고리의 다른 글

tclifconfig 0.1  (0) 2025.06.19
lpttcl 3.0  (0) 2025.06.19
Cryptkit 1.0  (0) 2025.04.17
TkTreeCtrl 2.4.1  (0) 2025.04.17
LED 0.0.2  (0) 2025.04.17