* doc/wm.n:

	* tests/winWm.test: Add 'wm attributes -alpha' to control toplevel
	* win/tkWinInt.h:   alpha transparency on Win2K/XP+.
	* win/tkWinWm.c:    TIP #222 [Patch 892194]

5 files changed, 216 insertions, 25 deletions

diff --git a/ChangeLog b/ChangeLog
index 836ce89..38f983b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 2004-09-17  Jeff Hobbs  <jeffh@ActiveState.com>
 
+	* doc/wm.n:
+	* tests/winWm.test: Add 'wm attributes -alpha' to control toplevel
+	* win/tkWinInt.h:   alpha transparency on Win2K/XP+.
+	* win/tkWinWm.c:    TIP #222 [Patch 892194]
+
 	* win/tkWinWm.c (UpdateWrapper): Ensure that we maintain Z order
 	* tests/winWm.test:              and focus of preexisting window
 	when replacing the wrapper window.
diff --git a/doc/wm.n b/doc/wm.n
index 9483994..507ac9a 100644
--- a/doc/wm.n
+++ b/doc/wm.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: wm.n,v 1.14 2004/06/21 19:56:11 dkf Exp $
+'\" RCS: @(#) $Id: wm.n,v 1.15 2004/09/17 23:26:21 hobbs Exp $
 '\" 
 .so man.macros
 .TH wm n 8.4 Tk "Tk Built-In Commands"
@@ -62,6 +62,11 @@ On Windows, \fB-disabled\fR gets or sets whether the window is in a
 disabled state. \fB-toolwindow\fR gets or sets the style of the window
 to toolwindow (as defined in the MSDN). \fB-topmost\fR gets or sets
 whether this is a topmost window (displays above all other windows).
+\fB-alpha\fR sets the transparency level of the toplevel.  It accepts
+a value from \fB0.0\fR (fully transparent) to \fB1.0\fR (opaque).  Values
+outside that range will be constrained.  Transparent toplevels are
+supported on Windows 2000/XP+.  Where not support, the \fB-alpha\fR value
+remains at \fB1.0\fR.
 .PP
 On Macintosh,
 .PP
diff --git a/tests/winWm.test b/tests/winWm.test
index 246aefa..51a86f0 100644
--- a/tests/winWm.test
+++ b/tests/winWm.test
@@ -9,7 +9,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: winWm.test,v 1.12 2004/09/17 22:44:34 hobbs Exp $
+# RCS: @(#) $Id: winWm.test,v 1.13 2004/09/17 23:26:21 hobbs Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
@@ -229,7 +229,7 @@ test winWm-6.1 {wm attributes} win {
     destroy .t
     toplevel .t
     wm attributes .t
-} {-disabled 0 -toolwindow 0 -topmost 0}
+} {-alpha 1.0 -disabled 0 -toolwindow 0 -topmost 0}
 test winWm-6.2 {wm attributes} win {
     destroy .t
     toplevel .t
@@ -240,7 +240,50 @@ test winWm-6.3 {wm attributes} win {
     destroy .t
     toplevel .t
     list [catch {wm attributes .t -foo} msg] $msg
-} {1 {wrong # args: should be "wm attributes window ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}}
+} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-disabled ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}}
+
+test winWm-6.4 {wm attributes -alpha} win {
+    # Expect this to return all 1.0 {} on pre-2K/XP
+    destroy .t
+    toplevel .t
+    set res [wm attributes .t -alpha]
+    # we don't return on set yet
+    lappend res [wm attributes .t -alpha 0.5]
+    lappend res [wm attributes .t -alpha]
+    lappend res [wm attributes .t -alpha -100]
+    lappend res [wm attributes .t -alpha]
+    lappend res [wm attributes .t -alpha 100]
+    lappend res [wm attributes .t -alpha]
+    set res
+} {1.0 {} 0.5 {} 0.0 {} 1.0}
+
+test winWm-6.5 {wm attributes -alpha} win {
+    destroy .t
+    toplevel .t
+    list [catch {wm attributes .t -alpha foo} msg] $msg
+} {1 {expected floating-point number but got "foo"}}
+
+test winWm-6.6 {wm attributes -alpha} win {
+    # This test is just to show off -alpha
+    destroy .t
+    toplevel .t
+    wm attributes .t -alpha 0.2
+    pack [label .t.l -text "Alpha Toplevel" -font "Helvetica 18 bold"]
+    tk::PlaceWindow .t center
+    update
+    if {$::tcl_platform(osVersion) >= 5.0} {
+	for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} {
+	    wm attributes .t -alpha $i
+	    update idle
+	    after 20
+	}
+	for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} {
+	    wm attributes .t -alpha $i
+	    update idle
+	    after 20
+	}
+    }
+} {}
 
 test winWm-7.1 {deiconify on an unmapped toplevel\
         will raise the window and set the focus} win {
diff --git a/win/tkWinInt.h b/win/tkWinInt.h
index ba8ad84..948bb94 100644
--- a/win/tkWinInt.h
+++ b/win/tkWinInt.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinInt.h,v 1.16 2004/08/20 00:58:52 hobbs Exp $
+ * RCS: @(#) $Id: tkWinInt.h,v 1.17 2004/09/17 23:26:21 hobbs Exp $
  */
 
 #ifndef _TKWININT
@@ -123,6 +123,7 @@ typedef struct {
  */
 
 #define TK_WIN_TOPLEVEL_CLASS_NAME "TkTopLevel"
+#define TK_WIN_TOPLEVEL_NOCDC_CLASS_NAME "TkTopLevelNoCDC"
 #define TK_WIN_CHILD_CLASS_NAME "TkChild"
 
 /*
diff --git a/win/tkWinWm.c b/win/tkWinWm.c
index cc77fe0..3d16632 100644
--- a/win/tkWinWm.c
+++ b/win/tkWinWm.c
@@ -12,12 +12,20 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tkWinWm.c,v 1.70 2004/09/17 22:44:34 hobbs Exp $
+ * RCS: @(#) $Id: tkWinWm.c,v 1.71 2004/09/17 23:26:21 hobbs Exp $
  */
 
 #include "tkWinInt.h"
 #include <shellapi.h>
 
+#ifndef WS_EX_LAYERED
+/*
+ * This is only valid on Win2K/XP+.
+ */
+#define WS_EX_LAYERED	0x00080000
+#define LWA_ALPHA	0x00000002
+#endif
+
 /*
  * Event structure for synthetic activation events.  These events are
  * placed on the event queue whenever a toplevel gets a WM_MOUSEACTIVATE
@@ -228,6 +236,8 @@ typedef struct TkWmInfo {
     DWORD style, exStyle;	/* Style flags for the wrapper window. */
     LONG styleConfig;		/* Extra user requested style bits */
     LONG exStyleConfig;		/* Extra user requested extended style bits */
+    double alpha;		/* Alpha transparency level
+				 * 0.0 (fully transparent) .. 1.0 (opaque) */
 
     /*
      * List of children of the toplevel which have private colormaps.
@@ -376,6 +386,13 @@ static int initialized;        /* Flag indicating whether module has
 DWORD* (WINAPI *shgetfileinfoProc) (LPCTSTR pszPath, DWORD dwFileAttributes,
     SHFILEINFO* psfi, UINT cbFileInfo, UINT uFlags) = NULL;
 
+/*
+ * A pointer to SetLayeredWindowAttributes (user32.dll) which we
+ * retrieve dynamically because it is only valid on Win2K+.
+ */
+BOOL (WINAPI *setLayeredWindowAttributesProc) (HWND hwnd, COLORREF crKey,
+	BYTE bAlpha, DWORD dwFlags) = NULL;
+
 TCL_DECLARE_MUTEX(winWmMutex)
 
 /*
@@ -825,6 +842,17 @@ InitWindowClass(WinIconPtr titlebaricon)
 		    FreeLibrary(hInstance);
 		}
 	    }
+	    if (setLayeredWindowAttributesProc == NULL) {
+		HINSTANCE hInstance = LoadLibraryA("user32");
+		if (hInstance != NULL) {
+		    setLayeredWindowAttributesProc =
+			(BOOL (WINAPI *) (HWND hwnd, COLORREF crKey,
+				BYTE bAlpha, DWORD dwFlags))
+			GetProcAddress(hInstance,
+				"SetLayeredWindowAttributes");
+		    FreeLibrary(hInstance);
+		}
+	    }
 	    /*
 	     * The only difference between WNDCLASSW and WNDCLASSA are
 	     * in pointers, so we can use the generic structure WNDCLASS.
@@ -867,6 +895,23 @@ InitWindowClass(WinIconPtr titlebaricon)
 	    if (!(*tkWinProcs->registerClass)(&class)) {
 		Tcl_Panic("Unable to register TkTopLevel class");
 	    }
+
+#ifndef TCL_THREADS
+	    /*
+	     * Use of WS_EX_LAYERED disallows CS_CLASSDC, as does
+	     * TCL_THREADS usage, so only create this if necessary.
+	     */
+	    if (setLayeredWindowAttributesProc != NULL) {
+		class.style = CS_HREDRAW | CS_VREDRAW;
+		Tcl_DStringFree(&classString);
+		Tcl_WinUtfToTChar(TK_WIN_TOPLEVEL_NOCDC_CLASS_NAME,
+			-1, &classString);
+		class.lpszClassName = (LPCTSTR) Tcl_DStringValue(&classString);
+		if (!(*tkWinProcs->registerClass)(&class)) {
+		    Tcl_Panic("Unable to register TkTopLevelNoCDC class");
+		}
+	    }
+#endif
 	    Tcl_DStringFree(&classString);
 	}
 	Tcl_MutexUnlock(&winWmMutex);
@@ -1848,6 +1893,7 @@ TkWmNewWindow(winPtr)
     wmPtr->height = -1;
     wmPtr->x = winPtr->changes.x;
     wmPtr->y = winPtr->changes.y;
+    wmPtr->alpha = 1.0;
 
     wmPtr->configWidth = -1;
     wmPtr->configHeight = -1;
@@ -2013,7 +2059,17 @@ UpdateWrapper(winPtr)
 	tsdPtr->createWindow = winPtr;
 	Tcl_WinUtfToTChar(((wmPtr->title != NULL) ?
                            wmPtr->title : winPtr->nameUid), -1, &titleString);
-	Tcl_WinUtfToTChar(TK_WIN_TOPLEVEL_CLASS_NAME, -1, &classString);
+#ifndef TCL_THREADS
+	/*
+	 * Transparent windows require a non-CS_CLASSDC window class.
+	 */
+	if ((wmPtr->exStyleConfig & WS_EX_LAYERED)
+		&& setLayeredWindowAttributesProc != NULL) {
+	    Tcl_WinUtfToTChar(TK_WIN_TOPLEVEL_NOCDC_CLASS_NAME,
+		    -1, &classString);
+	} else
+#endif
+	    Tcl_WinUtfToTChar(TK_WIN_TOPLEVEL_CLASS_NAME, -1, &classString);
 	wmPtr->wrapper = (*tkWinProcs->createWindowEx)(wmPtr->exStyle,
 		(LPCTSTR) Tcl_DStringValue(&classString),
 		(LPCTSTR) Tcl_DStringValue(&titleString),
@@ -2028,6 +2084,16 @@ UpdateWrapper(winPtr)
 #endif
 	tsdPtr->createWindow = NULL;
 
+	if ((wmPtr->exStyleConfig & WS_EX_LAYERED)
+		&& setLayeredWindowAttributesProc != NULL) {
+	    /*
+	     * The user supplies a double from [0..1], but Windows wants an
+	     * int (transparent) 0..255 (opaque), so do the translation.
+	     */
+	    setLayeredWindowAttributesProc((HWND) wmPtr->wrapper,
+		    (COLORREF) NULL, (BYTE) (wmPtr->alpha * 255), LWA_ALPHA);
+	}
+
 	place.length = sizeof(WINDOWPLACEMENT);
 	GetWindowPlacement(wmPtr->wrapper, &place);
 	wmPtr->x = place.rcNormalPosition.left;
@@ -2770,13 +2836,15 @@ WmAttributesCmd(tkwin, winPtr, interp, objc, objv)
 {
     register WmInfo *wmPtr = winPtr->wmInfoPtr;
     LONG style, exStyle, styleBit, *stylePtr;
-    char buf[TCL_INTEGER_SPACE], *string;
+    char *string;
     int i, boolean, length;
+    double alpha;
 
     if (objc < 3) {
         configArgs:
 	Tcl_WrongNumArgs(interp, 2, objv,
 		"window"
+		" ?-alpha ?double??"
 		" ?-disabled ?bool??"
 		" ?-toolwindow ?bool??"
 		" ?-topmost ?bool??");
@@ -2784,13 +2852,25 @@ WmAttributesCmd(tkwin, winPtr, interp, objc, objv)
     }
     exStyle = wmPtr->exStyleConfig;
     style   = wmPtr->styleConfig;
+    alpha   = wmPtr->alpha;
     if (objc == 3) {
-	sprintf(buf, "%d", ((style & WS_DISABLED) != 0));
-	Tcl_AppendResult(interp, "-disabled ", buf, (char *) NULL);
-	sprintf(buf, "%d", ((exStyle & WS_EX_TOOLWINDOW) != 0));
-	Tcl_AppendResult(interp, " -toolwindow ", buf, (char *) NULL);
-	sprintf(buf, "%d", ((exStyle & WS_EX_TOPMOST) != 0));
-	Tcl_AppendResult(interp, " -topmost ", buf, (char *) NULL);
+	Tcl_Obj *objPtr = Tcl_NewObj();
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewStringObj("-alpha", -1));
+	Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewDoubleObj(wmPtr->alpha));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewStringObj("-disabled", -1));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewBooleanObj((style & WS_DISABLED)));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewStringObj("-toolwindow", -1));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewBooleanObj((exStyle & WS_EX_TOOLWINDOW)));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewStringObj("-topmost", -1));
+	Tcl_ListObjAppendElement(NULL, objPtr,
+		Tcl_NewBooleanObj((exStyle & WS_EX_TOPMOST)));
+	Tcl_SetObjResult(interp, objPtr);
 	return TCL_OK;
     }
     for (i = 3; i < objc; i += 2) {
@@ -2798,13 +2878,12 @@ WmAttributesCmd(tkwin, winPtr, interp, objc, objv)
 	if ((length < 2) || (string[0] != '-')) {
 	    goto configArgs;
 	}
-	if ((i < objc-1) &&
-		(Tcl_GetBooleanFromObj(interp, objv[i+1], &boolean) != TCL_OK)) {
-	    return TCL_ERROR;
-	}
 	if (strncmp(string, "-disabled", length) == 0) {
 	    stylePtr = &style;
 	    styleBit = WS_DISABLED;
+	} else if (strncmp(string, "-alpha", length) == 0) {
+	    stylePtr = &exStyle;
+	    styleBit = WS_EX_LAYERED;
 	} else if ((strncmp(string, "-toolwindow", length) == 0)
 		   && (length >= 3)) {
 	    stylePtr = &exStyle;
@@ -2822,19 +2901,77 @@ WmAttributesCmd(tkwin, winPtr, interp, objc, objv)
 	} else {
 	    goto configArgs;
 	}
-	if (i == objc-1) {
-	    Tcl_SetIntObj(Tcl_GetObjResult(interp),
-		    ((*stylePtr & styleBit) != 0));
-	} else if (boolean) {
-	    *stylePtr |= styleBit;
+	if (styleBit == WS_EX_LAYERED) {
+	    double dval;
+
+	    if (i == objc-1) {
+		Tcl_SetDoubleObj(Tcl_GetObjResult(interp), wmPtr->alpha);
+	    } else {
+		if ((i < objc-1) &&
+			(Tcl_GetDoubleFromObj(interp, objv[i+1], &dval)
+				!= TCL_OK)) {
+		    return TCL_ERROR;
+		}
+		if (setLayeredWindowAttributesProc != NULL) {
+		    /*
+		     * The user should give (transparent) 0 .. 1.0 (opaque),
+		     * but we ignore the setting of this (it will always be 1)
+		     * in the case that the API is not available.
+		     */
+		    if (dval < 0.0) {
+			dval = 0;
+		    } else if (dval > 1.0) {
+			dval = 1;
+		    }
+		    wmPtr->alpha = dval;
+		    if (dval < 1.0) {
+			*stylePtr |= styleBit;
+		    } else {
+			*stylePtr &= ~styleBit;
+		    }
+		    if ((dval > 0) && (alpha > 0)) {
+			/*
+			 * If we are just changing transparency level, just
+			 * adjust the window setting (no UpdateWrapper).
+			 * The user supplies (opaque) 0..100 (transparent),
+			 * but Windows wants (transparent) 0..255 (opaque), so
+			 * do the translation.
+			 */
+			alpha = wmPtr->alpha;
+			setLayeredWindowAttributesProc((HWND) wmPtr->wrapper,
+				(COLORREF) NULL, (BYTE) (wmPtr->alpha * 255),
+				LWA_ALPHA);
+		    }
+		}
+	    }
 	} else {
-	    *stylePtr &= ~styleBit;
+	    if ((i < objc-1) &&
+		    (Tcl_GetBooleanFromObj(interp, objv[i+1], &boolean)
+			    != TCL_OK)) {
+		return TCL_ERROR;
+	    }
+	    if (i == objc-1) {
+		Tcl_SetIntObj(Tcl_GetObjResult(interp),
+			((*stylePtr & styleBit) != 0));
+	    } else if (boolean) {
+		*stylePtr |= styleBit;
+	    } else {
+		*stylePtr &= ~styleBit;
+	    }
 	}
     }
-    if ((wmPtr->styleConfig != style) ||
+    if ((wmPtr->styleConfig != style) || (wmPtr->alpha != alpha) ||
 	    (wmPtr->exStyleConfig != exStyle)) {
 	wmPtr->styleConfig = style;
 	wmPtr->exStyleConfig = exStyle;
+	/*
+	 * We could possibly avoid the UpdateWrapper with a SetWindowPos call
+	 * with SWP_FRAMECHANGED, but we need to handle the current styles
+	 * and the Config styles together.
+	SetWindowPos(wmPtr->wrapper, NULL, 0, 0, 0, 0,
+		SWP_NOMOVE|SWP_NOSIZE|SWP_NOACTIVATE|SWP_NOSENDCHANGING
+		|SWP_NOZORDER|SWP_FRAMECHANGED);
+	 */
 	UpdateWrapper(winPtr);
     }
     return TCL_OK;