GFWindowTransparency/Form1.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "GFWindowTransparency"
   ClientHeight    =   3090
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3090
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.TextBox Text1
      Height          =   315
      Left            =   1680
      TabIndex        =   4
      Text            =   "Text1"
      Top             =   360
      Width           =   2895
   End
   Begin VB.ListBox List1
      Height          =   1035
      Left            =   60
      TabIndex        =   3
      Top             =   780
      Width           =   4515
   End
   Begin VB.ComboBox Combo1
      Height          =   315
      Left            =   60
      TabIndex        =   2
      Text            =   "Combo1"
      Top             =   360
      Width           =   1575
   End
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   435
      Left            =   1980
      TabIndex        =   0
      Top             =   2580
      Width           =   2595
   End
   Begin VB.Label Label1
      Caption         =   "‑ Requires Win2k or above ‑"
      Height          =   195
      Left            =   60
      TabIndex        =   1
      Top             =   60
      Width           =   4515
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2003 by Louis. Adjusts a window's opacity (Win2k or above, does nothing under Win95/98/ME).
'GFWindowTransparency_DoFade
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
'Declare Function UpdateLayeredWindowNULL Lib "user32.dll" _
 (ByVal hWnd As Long, ByVal hdcDst As Long, ByRef pptDst As Point, _
 ByRef psize As SIZE, ByVal hdcSrc As Long, ByRef pptSrc As Point, _
 ByVal crKey As Long, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Long) As Long

 Private Declare Function UpdateLayeredWindowNULL Lib "user32.dll" Alias "UpdateLayeredWindow" _
 (ByVal hwnd As Long, ByVal hdcDst As Long, ByVal pptDst As Long, _
 ByVal psize As Long, ByVal hdcSrc As Long, ByVal pptSrc As Long, _
 ByVal crKey As Long, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Long) As Long

 Private Declare Function UpdateLayeredWindowEx Lib "user32.dll" Alias "UpdateLayeredWindow" _
 (ByVal hwnd As Long, ByVal hdcDst As Long, ByVal pptDst As Long, _
 ByRef psize As SIZE, ByVal hdcSrc As Long, ByRef pptSrc As POINTAPI, _
 ByVal crKey As Long, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Long) As Long

Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
'GFWindowTransparency_EnableFade
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
'Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
'GFWindowTransparency_DoFade
Private Const GWL_EXSTYLE = (‑20)
Private Const WS_EX_LAYERED As Long = &H80000
Private Const LWA_ALPHA As Long = &H2
'DEBUG
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long

Private Const WM_PAINT = &HF
Private Const WM_NCPAINT = &H85
Private Const WM_ERASEBKGND = &H14

'Private Const RDW_ALLCHILDREN = &H80
'Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ERASE = &H4
Private Const RDW_ALLCHILDREN = &H80

Private Const WM_CTLCOLORBTN = &H135
Private Const WM_CTLCOLORDLG = &H136
Private Const WM_CTLCOLOREDIT = &H133
Private Const WM_CTLCOLORLISTBOX = &H134
Private Const WM_CTLCOLORMSGBOX = &H132
Private Const WM_CTLCOLORSCROLLBAR = &H137
Private Const WM_CTLCOLORSTATIC = &H138

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type SIZE
    cx As Long
    cy As Long
End Type

Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'Private Const GWL_STYLE = (‑16)
'Private Const GWL_EXSTYLE = (‑20)
'Private Const WS_EX_LAYERED = &H80000
Private Const ULW_COLORKEY = &H1
Private Const ULW_ALPHA = &H2
Private Const ULW_OPAQUE = &H4
Private Const AC_SRC_OVER = &H0
Private Const AC_SRC_ALPHA = &H1
Private Const AC_SRC_NO_PREMULT_ALPHA = &H1
Private Const AC_SRC_NO_ALPHA = &H2
Private Const AC_DST_NO_PREMULT_ALPHA = &H10
Private Const AC_DST_NO_ALPHA = &H20
'Private Const LWA_COLORKEY = &H1
'Private Const LWA_ALPHA = &H2

Dim f As Boolean

Private Sub Command1_Click()
    'on error resume next
    Dim Temp As Long
    'begin
    For Temp = 0 To 100 Step 5
        Call GFWindowTransparency_DoFade(Me.hwnd, Temp)
        Call Sleep(15)
    Next Temp
    Call GFWindowTransparency_DisableFade(Me.hwnd)
    Call Sleep(1000)
    f = True
    Call GFWindowTransparency_EnableFade(Me.hwnd) 'flickers when updating window next time
    'Call SetLayeredWindowAttributes(Me.hwnd, 0&, 255, LWA_ALPHA)
'    Dim SizeSrc As SIZE
'    Dim PointSrc As POINTAPI
'    Dim b As BLENDFUNCTION
'
'    b.BlendOp = AC_SRC_OVER
'    b.SourceConstantAlpha = 100
'    PointSrc.x = 0
'    PointSrc.y = 0
'    SizeSrc.cx = Me.Width / Screen.TwipsPerPixelX
'    SizeSrc.cy = Me.Height / Screen.TwipsPerPixelY
'
'    Call UpdateLayeredWindowEx(Me.hwnd, 0, 0, SizeSrc, Me.hDC, PointSrc, 0, b, ULW_ALPHA)
    f = False
    'Me.Refresh
    'Call RedrawWindow(Me.hWnd, 0&, 0&, RDW_ERASENOW Or RDW_ALLCHILDREN)
    Call UpdateWindow(Me.hwnd)
    'Exit Sub
    For Temp = 100 To 0 Step ‑5
        Call GFWindowTransparency_DoFade(Me.hwnd, Temp)
        Call Sleep(15)
    Next Temp
    Call GFWindowTransparency_DisableFade(Me.hwnd)
End Sub

Private Function GFWindowTransparency_DoFade(ByVal WindowHandle As Long, ByVal WindowTransparencyPercentage As Integer) As Boolean 'from http://guille.costasol.net/api/LayeredWindows.htm (13.01.2003)
    On Error GoTo Error: 'important, if API functions not supported by OS; makes window (partially) transparent; returns True if window opacity has been changed, False if not (error)
    'verify
    Select Case WindowTransparencyPercentage
    Case Is < 0
        WindowTransparencyPercentage = 0
    Case Is > 100
        WindowTransparencyPercentage = 100
    End Select
    'preset
    WindowTransparencyPercentage = CInt(CSng(WindowTransparencyPercentage) * 2.55!)
    'begin
    If SetWindowLong(WindowHandle, GWL_EXSTYLE, GetWindowLong(WindowHandle, GWL_EXSTYLE) Or WS_EX_LAYERED) = 0& Then GoTo Error:
    'NOTE: if the function below is not known (under Win95/98/ME) then jump to Error:.
    If SetLayeredWindowAttributes(WindowHandle, 0&, WindowTransparencyPercentage, LWA_ALPHA) = 0& Then GoTo Error:
    Dim b As BLENDFUNCTION
    b.AlphaFormat = 0
    b.BlendFlags = 0
    b.BlendOp = AC_SRC_OVER
    b.SourceConstantAlpha = WindowTransparencyPercentage
    'Call UpdateLayeredWindowNULL(WindowHandle, 0, 0, 0, 0, 0, 0, b, ULW_ALPHA)
    Call UpdateWindow(WindowHandle) 'important, or there will be just a black box when the system is busy
    GFWindowTransparency_DoFade = True 'ok
    Exit Function
Error:
    GFWindowTransparency_DoFade = False 'error
    Exit Function
End Function

'***
'THE SHIT BELOW DOES NOT WORK!!!

'NOTE: call GFWindowTransparency_EnableFade() when a window is visible, does
'not have the GWL_EXSTYLE bit set and is to be faded out.
'After the fading call GFWindowTransparency_DisableFade() or the window will
'behave mysteriously when being resized or redrawn.

Private Function GFWindowTransparency_EnableFade(ByVal WindowHandle As Long)
    'on error resume next 'returns True for success or False for error
    '
    'NOTE: when a window is visible and we set the GWL_EXSTYLE bit and call
    'SetLayeredWindowAttributes() and the window is redrawn (sooner or later)
    'then its controls and its background will be drawn first in black and then correctly.
    'This looks like flickering. To avoid that the user sees the flickering we lock the
    'desktop window for a short moment (locking the original window has no effect).
    '
    If SetWindowLong(WindowHandle, GWL_EXSTYLE, GetWindowLong(WindowHandle, GWL_EXSTYLE) Or WS_EX_LAYERED) = 0& Then GoTo Error:
    'Debug.Print RedrawWindow(WindowHandle, 0&, 0&, RDW_ERASE Or RDW_INVALIDATE Or RDW_FRAME Or RDW_ALLCHILDREN)

    If SetLayeredWindowAttributes(WindowHandle, 0, 0, 0) = 0& Then GoTo Error:

    '
    'Call LockWindowUpdate(GetDesktopWindow) 'does not like this, black window background all the time
    Call UpdateWindow(Me.hwnd)
    'Call LockWindowUpdate(0&)
    '
    'NOTE: either the stuff flickers or it stays black :‑((
    '
    GFWindowTransparency_EnableFade = True 'ok
    Exit Function
Error:
    GFWindowTransparency_EnableFade = False 'error
    Exit Function
End Function

'***

Private Function GFWindowTransparency_DisableFade(ByVal WindowHandle As Long) As Boolean
    'on error resume next 'returns True if successful, False if not (WindowHandle invalid)
    '
    'NOTE: the target project should call this function after fading to remove the
    'layered style of the faded window to make its redrawing work much faster.
    '
    If SetWindowLong(WindowHandle, GWL_EXSTYLE, GetWindowLong(WindowHandle, GWL_EXSTYLE) Xor WS_EX_LAYERED) = 0& Then
        GFWindowTransparency_DisableFade = False 'error
    Else
        GFWindowTransparency_DisableFade = True 'ok
    End If
End Function

Private Sub Form_Load()
    Call GFSubClass(Me, "Me", Form1, True)
End Sub

Public Sub GFSubClassWindowProc(ByVal SourceDescription As String, ByVal hwnd As Long, ByRef Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef ReturnValue As Long, ByRef ReturnValueUsedFlag As Boolean)
    'on error resume next
    If (f) Then
        Select Case Msg
        Case WM_PAINT
            ReturnValueUsedFlag = True
            ReturnValue = 0
            'Msg = 0
        Case WM_NCPAINT
            'ReturnValueUsedFlag = True
            'ReturnValue = 0
        Case WM_ERASEBKGND
            ReturnValueUsedFlag = True
            ReturnValue = 1
            'Msg = 0
        Case WM_CTLCOLORBTN, WM_CTLCOLORDLG, _
            WM_CTLCOLOREDIT, WM_CTLCOLORLISTBOX, _
            WM_CTLCOLORMSGBOX, WM_CTLCOLORSCROLLBAR, _
            WM_CTLCOLORSTATIC

            ReturnValueUsedFlag = True
            ReturnValue = 0

        End Select
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call GFSubClass_Terminate
End Sub


[END OF FILE]