cShadow.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cShadow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************************************
'* cShadow - cSelfSub based sample that creates a form shadow.
'*
'* Note: because this sample will likely be used in the wild as-is, I've commented out the unused
'*  subclass procedures, sc_DelMsg, sc_CallOrigWndProc and the sc_lParamUser property
'*
'* Paul_Caton@hotmail.com
'* Copyright free, use and abuse as you see fit.
'*
'* v1.0 Re-write of the SelfSub/WinSubHook-2 submission to Planet Source Code............ 20060322
'* v1.1 Shadow color property added...................................................... 20060406
'*************************************************************************************************

Option Explicit

'-Selfsub declarations----------------------------------------------------------------------------
Private Enum eMsgWhen                                                       'When to callback
  MSG_BEFORE = 1                                                            'Callback before the original WndProc
  MSG_AFTER = 2                                                             'Callback after the original WndProc
  MSG_BEFORE_AFTER = MSG_BEFORE Or MSG_AFTER                                'Callback before and after the original WndProc
End Enum

Private Const ALL_MESSAGES  As Long = -1                                    'All messages callback
Private Const MSG_ENTRIES   As Long = 32                                    'Number of msg table entries
Private Const WNDPROC_OFF   As Long = &H38                                  'Thunk offset to the WndProc execution address
Private Const GWL_WNDPROC   As Long = -4                                    'SetWindowsLong WndProc index
Private Const IDX_SHUTDOWN  As Long = 1                                     'Thunk data index of the shutdown flag
Private Const IDX_HWND      As Long = 2                                     'Thunk data index of the subclassed hWnd
Private Const IDX_WNDPROC   As Long = 9                                     'Thunk data index of the original WndProc
Private Const IDX_BTABLE    As Long = 11                                    'Thunk data index of the Before table
Private Const IDX_ATABLE    As Long = 12                                    'Thunk data index of the After table
Private Const IDX_PARM_USER As Long = 13                                    'Thunk data index of the User-defined callback parameter data index

Private z_ScMem             As Long                                         'Thunk base address
Private z_Sc(64)            As Long                                         'Thunk machine-code initialised here
Private z_Funk              As Collection                                   'hWnd/thunk-address collection

Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Private Const DEF_COLOR             As Long = 0
Private Const DEF_DEPTH             As Long = 7
Private Const DEF_TRANSPARENCY      As Long = 140

Private Const AC_SRC_OVER           As Long = &H0
Private Const AC_SRC_ALPHA          As Long = &H1
Private Const BITSPIXEL             As Long = 12
Private Const SIZE_RESTORED         As Long = 0
Private Const SW_HIDE               As Long = 0
Private Const SW_SHOWNOACTIVATE     As Long = 4
Private Const SWP_HIDEWINDOW        As Long = &H80
Private Const SWP_SHOWWINDOW        As Long = &H40
Private Const ULW_ALPHA             As Long = &H2

Private Const WM_MDIACTIVATE        As Long = &H222
Private Const WM_DISPLAYCHANGE      As Long = &H7E
Private Const WM_THEMECHANGED       As Long = &H31A
Private Const WM_WINDOWPOSCHANGED   As Long = &H47
Private Const WM_SIZE               As Long = &H5
Private Const WS_EX_LAYERED         As Long = &H80000
Private Const WS_EX_NOPARENTNOTIFY  As Long = &H4
Private Const WS_EX_TRANSPARENT     As Long = &H20
Private Const WS_POPUP              As Long = &H80000000

Private Type tBGRA
    Blue                            As Byte
    Green                           As Byte
    Red                             As Byte
    Alpha                           As Byte
End Type

Private Type tBITMAPINFOHEADER
  biSize                            As Long
  biWidth                           As Long
  biHeight                          As Long
  biPlanes                          As Integer
  biBitCount                        As Integer
  biCompression                     As Long
  biSizeImage                       As Long
  biXPelsPerMeter                   As Long
  biYPelsPerMeter                   As Long
  biClrUsed                         As Long
  biClrImportant                    As Long
End Type

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

Private Type tOSVERSIONINFO
  dwOSVersionInfoSize               As Long
  dwMajorVersion                    As Long
  dwMinorVersion                    As Long
  dwBuildNumber                     As Long
  dwPlatformId                      As Long
  szCSDVersion                      As String * 128
End Type

Private Type tPOINT
  x                                 As Long
  y                                 As Long
End Type

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

Private Type tSAFEARRAYBOUND
  cElements                         As Long
  lLbound                           As Long
End Type

Private Type tSAFEARRAY2D
  cDims                             As Integer
  fFeatures                         As Integer
  cbElements                        As Long
  cLocks                            As Long
  pvData                            As Long
  Bounds(0 To 1)                    As tSAFEARRAYBOUND
End Type

Private Type tSIZE
  cx                                As Long
  cy                                As Long
End Type

Private Type tWINDOWPOS
  hwnd                              As Long
  hWndInsertAfter                   As Long
  x                                 As Long
  y                                 As Long
  cx                                As Long
  cy                                As Long
  flags                             As Long
End Type

Private m_Color                     As Long                                 'Private shadow color property value
Private m_Depth                     As Long                                 'Private shadow depth property value
Private m_Transparency              As Long                                 'Private shadow transparency property value

Private bIsLayered                  As Boolean                              'Layered windows supported
Private bIsLuna                     As Boolean                              'Luna theme?
Private bIsXP                       As Boolean                              'Windows XP?
Private bLastShow                   As Boolean                              'The previous show state
Private cx                          As Long                                 'Width
Private cy                          As Long                                 'Height
Private hWndBt                      As Long                                 'Bottom shadow window handle
Private hWndRt                      As Long                                 'Right shadow window handle
Private hWndForm                    As Long                                 'Parent window handle
Private wp                          As tWINDOWPOS                           'Parent window position

Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As tBITMAPINFOHEADER, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateWindowExA Lib "user32" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function GetCurrentThemeName Lib "uxtheme.dll" (ByVal pszThemeFileName As Long, ByVal cchMaxNameChars As Long, ByVal pszColorBuff As Long, ByVal cchMaxColorChars As Long, ByVal pszSizeBuff As Long, ByVal cchMaxSizeChars As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetThemeDocumentationProperty Lib "uxtheme.dll" (ByVal pszThemeName As Long, ByVal pszPropertyName As Long, ByVal pszValueBuff As Long, ByVal cchMaxValChars As Long) As Long
Private Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As tOSVERSIONINFO) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal hDcDest As Long, ptDst As Any, pSize As Any, ByVal hDcSrc As Long, ptSrc As Any, ByVal crKey As Long, pBlend As Any, ByVal dwFlags As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Sub Class_Initialize()                                              'Class initialization
  CheckEnvironment
  m_Depth = DEF_DEPTH
  m_Transparency = DEF_TRANSPARENCY
End Sub

Private Sub Class_Terminate()
  sc_Terminate                                                              'Terminate all subclassing
  
  If hWndRt <> 0 Then
    DestroyWindow hWndRt
    DestroyWindow hWndBt
  End If
End Sub

'Shadow depth property
Public Property Get Color() As Long
  Color = m_Color
End Property
'
Public Property Let Color(ByVal NewValue As Long)
  Const COLOR_SYS_MASK As Long = &H80000000
  
  If (NewValue And COLOR_SYS_MASK) Then                                       'If the system color bit is set
    NewValue = GetSysColor(NewValue Xor COLOR_SYS_MASK)                       'Get the translated system color
  End If
  
  If NewValue <> m_Color Then
    m_Color = NewValue
    DisplayShadows
  End If
End Property

'Shadow depth property
Public Property Get Depth() As Long
  Depth = m_Depth
End Property
'
Public Property Let Depth(ByVal NewValue As Long)
  If NewValue <> m_Depth Then
    m_Depth = NewValue
    DisplayShadows
  End If
End Property

'Shadow transparency property
Public Property Get Transparency() As Byte
  Transparency = CByte(m_Transparency)
End Property
'
Public Property Let Transparency(ByVal NewValue As Byte)
  If NewValue <> m_Transparency Then
    m_Transparency = CLng(NewValue)
    DisplayShadows
  End If
End Property

'Set the form to be shadowed
Public Function Shadow(frm As Form) As Boolean
  If hWndForm <> 0 Then
    zError "Shadow", "Only a single form per cShadow instance is allowed"
    Exit Function
  End If

  If bIsLayered Then
    hWndForm = frm.hwnd
  
    If sc_Subclass(hWndForm) Then
      sc_AddMsg hWndForm, WM_WINDOWPOSCHANGED, MSG_BEFORE
      sc_AddMsg hWndForm, WM_SIZE, MSG_BEFORE
      sc_AddMsg hWndForm, WM_DISPLAYCHANGE, MSG_BEFORE
      
      If bIsXP Then
        sc_AddMsg hWndForm, WM_THEMECHANGED, MSG_BEFORE
      End If
      
      CreateWindows
      Shadow = True
    End If
  End If
End Function

'Validate the OS and color depth
Private Sub CheckEnvironment()
  Dim OSV As tOSVERSIONINFO

  bIsLayered = False

  With OSV
    .dwOSVersionInfoSize = Len(OSV)                                         'Set the length element
    GetVersionExA OSV                                                       'Fill the type with OS version info

    'If .dwPlatformId = 2 Then                                               'If it's an NT based OS
      'If .dwMajorVersion = 5 Then                                           'If the major version is 5 OS supports transparency
        'If .dwMinorVersion > 0 Then
          'bIsXP = True
          'bIsLuna = IsLuna                                                  'Determine if the Luna theme is active
        'End If

        'bIsLayered = (GetDeviceCaps(GetDC(0), BITSPIXEL) >= 16)             'Ensure we have enough screen colors
      'End If
    'End If
    
    If .dwMajorVersion >= 5 Then                                       'If the major version is 5 or greater then the OS supports transparency
      bIsLayered = True
      
      If .dwMinorVersion > 0 Then
        bIsXP = True                                                  'Assume luna window shape, if people like this control enough i'll access the theme api's to get the actual window shape.
        bIsLuna = IsLuna
      End If
      
      bIsLayered = (GetDeviceCaps(GetDC(0), BITSPIXEL) >= 16)           'Ensure we have enough screen colors
    End If
  End With
End Sub

''Return whether the OS supports layered windows
'Private Function pLayered() As Boolean
'  Dim OSV As tOSVERSIONINFO
'
'  With OSV
'    .dwOSVersionInfoSize = Len(OSV)                                   'Set the length element
'    Call GetVersionEx(OSV)                                            'Fill the type with OS version info
'
'    If .dwMajorVersion >= 5 Then                                       'If the major version is 5 or greater then the OS supports transparency
'      pLayered = True
'
'      If .dwMinorVersion > 0 Then
'        bWinXP = True                                                  'Assume luna window shape, if people like this control enough i'll access the theme api's to get the actual window shape.
'      End If
'
'      pLayered = (GetDeviceCaps(GetDC(0), BITSPIXEL) >= 16)           'Ensure we have enough screen colors
'    End If
'  End With
'
''DEVELOPER!! Alpha transparency isn't supported on your platform
'  Debug.Assert pLayered
'End Function


'Create the shadow windows
Private Sub CreateWindows()
  Const EX_STYLE As Long = WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_NOPARENTNOTIFY

  hWndRt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, App.hInstance, 0)
  hWndBt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, App.hInstance, 0)
End Sub

'Display the right and bottom shadows
Private Sub DisplayShadows()
  If bIsLayered Then
    If IsWindowVisible(hWndForm) <> 0 Then
      With wp
'        DisplayShadowSub .x + .cx, .y + m_Depth, m_Depth, .cy, True
        DisplayShadowSub .x + m_Depth, .y + .cy, .cx - 2 * m_Depth, m_Depth, False
      End With
    End If
  End If
End Sub

'Display the content of the specified shadow window
Private Sub DisplayShadowSub(ByVal x As Long, ByVal y As Long, cx As Long, cy As Long, ByVal bRight As Boolean)
  Dim dc        As Long
  Dim iX        As Long
  Dim iY        As Long
  Dim hDib      As Long
  Dim hWin      As Long
  Dim nAlpha    As Long
  Dim aPixels() As Long
  Dim pBmpBits  As Long
  Dim pt0       As tPOINT
  Dim pt        As tPOINT
  Dim sz        As tSIZE
  Dim bs        As tBLENDFUNCTION
  Dim bmpHeader As tBITMAPINFOHEADER
  Dim SafeArray As tSAFEARRAY2D

  dc = CreateCompatibleDC(0)                                                'Get a screen compatible memory dc

  With bmpHeader                                                            'Initialize a bitmap header
    .biSize = Len(bmpHeader)                                                'Bitmap header size
    .biWidth = cx                                                           'Bitmap/window pixel width
    .biHeight = cy                                                          'Bitmap/window pixel height
    .biPlanes = 1                                                           'Graphics planes
    .biBitCount = 32                                                        '32bits per pixel BGRA (Blue, Green, Red, Alpha)
    .biSizeImage = cx * cy * 4                                              'Memory size, width * height * 32bit
  End With

  hDib = CreateDIBSection(dc, bmpHeader, 0, pBmpBits, 0, 0)                 'Create a device independant bitmap as per the header, compatible with the dc (compatible with the screen)

  With SafeArray                                                            'Construct a VB safearray header that matches the specs of the bitmap
    .cbElements = 4                                                         '4 bytes per element - 32bits per pixel
    .cDims = 2                                                              'We'll treat the pixels as a two dimensional (x, y) array
    .pvData = pBmpBits                                                      'The data pointer points to the bitmap data (pixels)
    .Bounds(0).lLbound = 0                                                  'Lowest bound will be 0
    .Bounds(0).cElements = cy                                               'The number of elements
    .Bounds(1).lLbound = 0                                                  'Lowest bound will be 0
    .Bounds(1).cElements = cx                                               'The number of elements
  End With

  CopyMemory ByVal VarPtrArray(aPixels()), VarPtr(SafeArray), 4             'Copy the address of our safearray over the address of aPixels() safearray

  If bRight Then
    hWin = hWndRt
  Else
    hWin = hWndBt
  End If

  If bRight Then
    For iY = 0 To cy - 1
      If iY < cx Then
        nAlpha = (255 * iY) \ cx
      ElseIf iY >= (cy - cx) Then
        nAlpha = ((cy - iY) * 255) \ cx
      Else
        nAlpha = 255
      End If

      For iX = 0 To cx - 1
        aPixels(iX, iY) = MakeBGRA((nAlpha * (cx - iX)) \ cx)
      Next iX
    Next iY
  Else
    For iX = 0 To cx - 1
      If iX < cy Then
        nAlpha = (255 * iX) \ cy
      ElseIf iX >= (cx - cy) Then
        nAlpha = ((cx - iX) * 255) \ cy
      Else
        nAlpha = 255
      End If

      For iY = 0 To cy - 1
        aPixels(iX, iY) = MakeBGRA((nAlpha * iY) \ cy)
      Next iY
    Next iX
  End If

  If bRight Then
    If bIsLuna Then
      On Error Resume Next                                                  'Protect against shadow depths less than 5
      aPixels(cx - 1, cy - 1) = 0
      aPixels(cx - 2, cy - 1) = 0
      aPixels(cx - 3, cy - 1) = 0
      aPixels(cx - 4, cy - 1) = 0
      aPixels(cx - 5, cy - 1) = 0

      aPixels(cx - 1, cy - 2) = 0
      aPixels(cx - 2, cy - 2) = 0
      aPixels(cx - 3, cy - 2) = 0

      aPixels(cx - 1, cy - 3) = 0
      aPixels(cx - 2, cy - 3) = 0

      aPixels(cx - 1, cy - 4) = 0
      aPixels(cx - 1, cy - 5) = 0
      On Error GoTo 0
    End If
  End If

  CopyMemory ByVal VarPtrArray(aPixels()), 0&, 4
  
  With bs                                                                   'Setup the blend function
    .AlphaFormat = AC_SRC_ALPHA                                             'Use the alpha channel for individual pixel transparency
    .BlendFlags = 0
    .BlendOp = AC_SRC_OVER                                                  'Alpha overlay
    .SourceConstantAlpha = m_Transparency                                   'Alpha transparency for overall transparency
  End With

  pt.x = x                                                                  'Setup the window position and size data
  pt.y = y
  sz.cx = cx
  sz.cy = cy

  hDib = SelectObject(dc, hDib)                                             'Select the bitmap into the memory display context
  UpdateLayeredWindow hWin, dc, pt, sz, dc, pt0, 0, bs, ULW_ALPHA           'Do the layered update
  SelectObject dc, hDib                                                     'Trash the bitmap
  DeleteDC dc                                                               'Delete the memory display context
End Sub

'Return whether the Luna theme is active
Private Function IsLuna() As Boolean
  Dim hLib   As Long
  Dim nPos   As Long
  Dim sTheme As String
  Dim sName  As String

  hLib = LoadLibraryA("uxtheme.dll")

  If hLib <> 0 Then
    sTheme = String$(255, 0)

    GetCurrentThemeName StrPtr(sTheme), Len(sTheme), 0, 0, 0, 0
    nPos = InStr(1, sTheme, vbNullChar)

    If nPos > 0 Then
      sTheme = Left$(sTheme, nPos - 1)
      sName = String$(255, 0)

      GetThemeDocumentationProperty StrPtr(sTheme), StrPtr("ThemeName"), StrPtr(sName), Len(sName)
      nPos = InStr(1, sName, vbNullChar)

      If nPos > 0 Then
        sName = Left$(sName, nPos - 1)
        bIsLuna = (StrComp(sName, "Luna", vbTextCompare) = 0)
      End If
    End If

    FreeLibrary hLib
  End If
End Function

'Pre-multiply the shadow color with the passed alpha value. This is needed to get nice looking colors according to MSDN.
Private Function MakeBGRA(ByVal Alpha As Byte) As Long
  Dim fFactor As Double
  Dim BGRA    As tBGRA
    
  fFactor = CDbl(Alpha) / 255#                                              'Calculate the factor
  
'Note that nColor is in RGB format, part of this process is to convert to BGRA format
  With BGRA                                                                 'Blue, Green, Red, Alpha
    .Blue = ((m_Color And &HFF0000) \ &H10000) * fFactor                     'Factor the blue component
    .Green = ((m_Color And &HFF00&) \ &H100&) * fFactor                      'Factor the green component
    .Red = (m_Color And &HFF) * fFactor                                      'Factor the red component
    .Alpha = Alpha                                                          'Store the alpha value
  End With
  
'Copy the BGRA type to long
  CopyMemory MakeBGRA, BGRA, 4
End Function

'Show/hide the shadow windows
Private Sub Show(ByVal bShow As Boolean, Optional ByVal bForce As Boolean = False)
  If Not bForce Then
    If bLastShow = bShow Then
      Exit Sub
    End If
  End If

  bLastShow = bShow

  If bShow Then
    ShowWindow hWndRt, SW_SHOWNOACTIVATE
    ShowWindow hWndBt, SW_SHOWNOACTIVATE
  Else
    ShowWindow hWndRt, SW_HIDE
    ShowWindow hWndBt, SW_HIDE
  End If
End Sub

'Size/position the shadows
Private Sub SizePos()
  With wp
    If .flags And SWP_HIDEWINDOW Then                                       'If the parent form is being hidden
      Show False                                                            'Hide the shadow windows also

    Else
      If .cx <> cx Then                                                     'If the parent's width has changed
        cx = .cx                                                            'Store the new width
        DisplayShadowSub .x + m_Depth, .y + .cy, .cx - 2 * m_Depth, m_Depth, False
      End If

      If .cy <> cy Then                                                     'If the parent's height has changed
        cy = .cy                                                            'Store the new height
'        DisplayShadowSub .x + .cx, .y + m_Depth, m_Depth, .cy, True
      End If

      MoveWindow hWndRt, .x + .cx, .y + m_Depth, m_Depth, .cy, False
      MoveWindow hWndBt, .x + m_Depth, .y + .cy, .cx - m_Depth, m_Depth, False

      If (.flags And SWP_SHOWWINDOW) Then
        Show True
      End If
    End If
  End With
End Sub

'-SelfSub code------------------------------------------------------------------------------------
Private Function sc_Subclass(ByVal lng_hWnd As Long, _
                    Optional ByVal lParamUser As Long = 0, _
                    Optional ByVal nOrdinal As Long = 1, _
                    Optional ByVal oCallback As Object = Nothing, _
                    Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'*************************************************************************************************
'* lng_hWnd   - Handle of the window to subclass
'* lParamUser - Optional, user-defined callback parameter
'* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
'* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
'* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'*************************************************************************************************
Const CODE_LEN      As Long = 260                                           'Thunk length in bytes
Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1))            'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX      As Long = &H40&                                         'Allocate executable memory
Const MEM_COMMIT    As Long = &H1000&                                       'Commit allocated memory
Const MEM_RELEASE   As Long = &H8000&                                       'Release allocated memory flag
Const IDX_EBMODE    As Long = 3                                             'Thunk data index of the EbMode function address
Const IDX_CWP       As Long = 4                                             'Thunk data index of the CallWindowProc function address
Const IDX_SWL       As Long = 5                                             'Thunk data index of the SetWindowsLong function address
Const IDX_FREE      As Long = 6                                             'Thunk data index of the VirtualFree function address
Const IDX_BADPTR    As Long = 7                                             'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER     As Long = 8                                             'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK  As Long = 10                                            'Thunk data index of the callback method address
Const IDX_EBX       As Long = 16                                            'Thunk code patch index of the thunk data
Const SUB_NAME      As String = "sc_Subclass"                               'This routine's name
  Dim nAddr         As Long
  Dim nID           As Long
  Dim nMyID         As Long
  
  If IsWindow(lng_hWnd) = 0 Then                                            'Ensure the window handle is valid
    zError SUB_NAME, "Invalid window handle"
    Exit Function
  End If

  nMyID = GetCurrentProcessId                                               'Get this process's ID
  GetWindowThreadProcessId lng_hWnd, nID                                    'Get the process ID associated with the window handle
  If nID <> nMyID Then                                                      'Ensure that the window handle doesn't belong to another process
    zError SUB_NAME, "Window handle belongs to another process"
    Exit Function
  End If
  
  If oCallback Is Nothing Then                                              'If the user hasn't specified the callback owner
    Set oCallback = Me                                                      'Then it is me
  End If
  
  nAddr = zAddressOf(oCallback, nOrdinal)                                   'Get the address of the specified ordinal method
  If nAddr = 0 Then                                                         'Ensure that we've found the ordinal method
    zError SUB_NAME, "Callback method not found"
    Exit Function
  End If
    
  If z_Funk Is Nothing Then                                                 'If this is the first time through, do the one-time initialization
    Set z_Funk = New Collection                                             'Create the hWnd/thunk-address collection
    z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(17) = &H4339F631: z_Sc(18) = &H4A21750C: z_Sc(19) = &HE82C7B8B: z_Sc(20) = &H74&: z_Sc(21) = &H75147539: z_Sc(22) = &H21E80F: z_Sc(23) = &HD2310000: z_Sc(24) = &HE8307B8B: z_Sc(25) = &H60&: z_Sc(26) = &H10C261: z_Sc(27) = &H830C53FF: z_Sc(28) = &HD77401F8: z_Sc(29) = &H2874C085: z_Sc(30) = &H2E8&: z_Sc(31) = &HFFE9EB00: z_Sc(32) = &H75FF3075: z_Sc(33) = &H2875FF2C: z_Sc(34) = &HFF2475FF: z_Sc(35) = &H3FF2473: z_Sc(36) = &H891053FF: z_Sc(37) = &HBFF1C45: z_Sc(38) = &H73396775: z_Sc(39) = &H58627404
    z_Sc(40) = &H6A2473FF: z_Sc(41) = &H873FFFC: z_Sc(42) = &H891453FF: z_Sc(43) = &H7589285D: z_Sc(44) = &H3045C72C: z_Sc(45) = &H8000&: z_Sc(46) = &H8920458B: z_Sc(47) = &H4589145D: z_Sc(48) = &HC4836124: z_Sc(49) = &H1862FF04: z_Sc(50) = &H35E30F8B: z_Sc(51) = &HA78C985: z_Sc(52) = &H8B04C783: z_Sc(53) = &HAFF22845: z_Sc(54) = &H73FF2775: z_Sc(55) = &H1C53FF28: z_Sc(56) = &H438D1F75: z_Sc(57) = &H144D8D34: z_Sc(58) = &H1C458D50: z_Sc(59) = &HFF3075FF: z_Sc(60) = &H75FF2C75: z_Sc(61) = &H873FF28: z_Sc(62) = &HFF525150: z_Sc(63) = &H53FF2073: z_Sc(64) = &HC328&

    z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA")                    'Store CallWindowProc function address in the thunk data
    z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA")                     'Store the SetWindowLong function address in the thunk data
    z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree")                     'Store the VirtualFree function address in the thunk data
    z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr")                  'Store the IsBadCodePtr function address in the thunk data
  End If
  
  z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX)                  'Allocate executable memory

  If z_ScMem <> 0 Then                                                      'Ensure the allocation succeeded
    On Error GoTo CatchDoubleSub                                            'Catch double subclassing
      z_Funk.Add z_ScMem, "h" & lng_hWnd                                    'Add the hWnd/thunk-address to the collection
    On Error GoTo 0
  
    If bIdeSafety Then                                                      'If the user wants IDE protection
      z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode")                          'Store the EbMode function address in the thunk data
    End If
    
    z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
    z_Sc(IDX_HWND) = lng_hWnd                                               'Store the window handle in the thunk data
    z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
    z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
    z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
    z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
    z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
    
    nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
    If nAddr = 0 Then                                                       'Ensure the new WndProc was set correctly
      zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
      GoTo ReleaseMemory
    End If
        
    z_Sc(IDX_WNDPROC) = nAddr                                               'Store the original WndProc address in the thunk data
    RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
    sc_Subclass = True                                                      'Indicate success
  Else
    zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  End If
  
  Exit Function                                                             'Exit sc_Subclass

CatchDoubleSub:
  zError SUB_NAME, "Window handle is already subclassed"
  
ReleaseMemory:
  VirtualFree z_ScMem, 0, MEM_RELEASE                                       'sc_Subclass has failed after memory allocation, so release the memory
End Function

'Terminate all subclassing
Private Sub sc_Terminate()
  Dim i As Long

  If Not (z_Funk Is Nothing) Then                                           'Ensure that subclassing has been started
    With z_Funk
      For i = .Count To 1 Step -1                                           'Loop through the collection of window handles in reverse order
        z_ScMem = .Item(i)                                                  'Get the thunk address
        If IsBadCodePtr(z_ScMem) = 0 Then                                   'Ensure that the thunk hasn't already released its memory
          sc_UnSubclass zData(IDX_HWND)                                     'UnSubclass
        End If
      Next i                                                                'Next member of the collection
    End With
    Set z_Funk = Nothing                                                    'Destroy the hWnd/thunk-address collection
  End If
End Sub

'UnSubclass the specified window handle
Private Sub sc_UnSubclass(ByVal lng_hWnd As Long)
  If z_Funk Is Nothing Then                                                 'Ensure that subclassing has been started
    zError "sc_UnSubclass", "Window handle isn't subclassed"
  Else
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                           'Ensure that the thunk hasn't already released its memory
      zData(IDX_SHUTDOWN) = -1                                              'Set the shutdown indicator
      zDelMsg ALL_MESSAGES, IDX_BTABLE                                      'Delete all before messages
      zDelMsg ALL_MESSAGES, IDX_ATABLE                                      'Delete all after messages
    End If
    z_Funk.Remove "h" & lng_hWnd                                            'Remove the specified window handle from the collection
  End If
End Sub

'Add the message value to the window handle's specified callback table
Private Sub sc_AddMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    If When And MSG_BEFORE Then                                             'If the message is to be added to the before original WndProc table...
      zAddMsg uMsg, IDX_BTABLE                                              'Add the message to the before table
    End If
    If When And MSG_AFTER Then                                              'If message is to be added to the after original WndProc table...
      zAddMsg uMsg, IDX_ATABLE                                              'Add the message to the after table
    End If
  End If
End Sub

'Delete the message value from the window handle's specified callback table
Private Sub sc_DelMsg(ByVal lng_hWnd As Long, ByVal uMsg As Long, Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    If When And MSG_BEFORE Then                                             'If the message is to be deleted from the before original WndProc table...
      zDelMsg uMsg, IDX_BTABLE                                              'Delete the message from the before table
    End If
    If When And MSG_AFTER Then                                              'If the message is to be deleted from the after original WndProc table...
      zDelMsg uMsg, IDX_ATABLE                                              'Delete the message from the after table
    End If
  End If
End Sub

'Call the original WndProc
Private Function sc_CallOrigWndProc(ByVal lng_hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    sc_CallOrigWndProc = _
        CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam) 'Call the original WndProc of the passed window handle parameter
  End If
End Function

'Get the subclasser lParamUser callback parameter
Private Property Get sc_lParamUser(ByVal lng_hWnd As Long) As Long
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    sc_lParamUser = zData(IDX_PARM_USER)                                    'Get the lParamUser callback parameter
  End If
End Property

'Let the subclasser lParamUser callback parameter
Private Property Let sc_lParamUser(ByVal lng_hWnd As Long, ByVal NewValue As Long)
  If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then                             'Ensure that the thunk hasn't already released its memory
    zData(IDX_PARM_USER) = NewValue                                         'Set the lParamUser callback parameter
  End If
End Property

'-The following routines are exclusively for the sc_ subclass routines----------------------------

'Add the message to the specified table of the window handle
Private Sub zAddMsg(ByVal uMsg As Long, ByVal nTable As Long)
  Dim nCount As Long                                                        'Table entry count
  Dim nBase  As Long                                                        'Remember z_ScMem
  Dim i      As Long                                                        'Loop index

  nBase = z_ScMem                                                            'Remember z_ScMem so that we can restore its value on exit
  z_ScMem = zData(nTable)                                                    'Map zData() to the specified table

  If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being added to the table...
    nCount = ALL_MESSAGES                                                   'Set the table entry count to ALL_MESSAGES
  Else
    nCount = zData(0)                                                       'Get the current table entry count
    If nCount >= MSG_ENTRIES Then                                           'Check for message table overflow
      zError "zAddMsg", "Message table overflow. Either increase the value of Const MSG_ENTRIES or use ALL_MESSAGES instead of specific message values"
      GoTo Bail
    End If

    For i = 1 To nCount                                                     'Loop through the table entries
      If zData(i) = 0 Then                                                  'If the element is free...
        zData(i) = uMsg                                                     'Use this element
        GoTo Bail                                                           'Bail
      ElseIf zData(i) = uMsg Then                                           'If the message is already in the table...
        GoTo Bail                                                           'Bail
      End If
    Next i                                                                  'Next message table entry

    nCount = i                                                              'On drop through: i = nCount + 1, the new table entry count
    zData(nCount) = uMsg                                                    'Store the message in the appended table entry
  End If

  zData(0) = nCount                                                         'Store the new table entry count
Bail:
  z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Delete the message from the specified table of the window handle
Private Sub zDelMsg(ByVal uMsg As Long, ByVal nTable As Long)
  Dim nCount As Long                                                        'Table entry count
  Dim nBase  As Long                                                        'Remember z_ScMem
  Dim i      As Long                                                        'Loop index

  nBase = z_ScMem                                                           'Remember z_ScMem so that we can restore its value on exit
  z_ScMem = zData(nTable)                                                   'Map zData() to the specified table

  If uMsg = ALL_MESSAGES Then                                               'If ALL_MESSAGES are being deleted from the table...
    zData(0) = 0                                                            'Zero the table entry count
  Else
    nCount = zData(0)                                                       'Get the table entry count
    
    For i = 1 To nCount                                                     'Loop through the table entries
      If zData(i) = uMsg Then                                               'If the message is found...
        zData(i) = 0                                                        'Null the msg value -- also frees the element for re-use
        GoTo Bail                                                           'Bail
      End If
    Next i                                                                  'Next message table entry
    
    zError "zDelMsg", "Message &H" & Hex$(uMsg) & " not found in table"
  End If
  
Bail:
  z_ScMem = nBase                                                           'Restore the value of z_ScMem
End Sub

'Error handler
Private Sub zError(ByVal sRoutine As String, ByVal sMsg As String)
  App.LogEvent TypeName(Me) & "." & sRoutine & ": " & sMsg, vbLogEventTypeError
  MsgBox sMsg & ".", vbExclamation + vbApplicationModal, "Error in " & TypeName(Me) & "." & sRoutine
End Sub

'Return the address of the specified DLL/procedure
Private Function zFnAddr(ByVal sDLL As String, ByVal sProc As String) As Long
  zFnAddr = GetProcAddress(GetModuleHandleA(sDLL), sProc)                   'Get the specified procedure address
  Debug.Assert zFnAddr                                                      'In the IDE, validate that the procedure address was located
End Function

'Map zData() to the thunk address for the specified window handle
Private Function zMap_hWnd(ByVal lng_hWnd As Long) As Long
  If z_Funk Is Nothing Then                                                 'Ensure that subclassing has been started
    zError "zMap_hWnd", "Subclassing hasn't been started"
  Else
    On Error GoTo Catch                                                     'Catch unsubclassed window handles
    z_ScMem = z_Funk("h" & lng_hWnd)                                        'Get the thunk address
    zMap_hWnd = z_ScMem
  End If
  
  Exit Function                                                             'Exit returning the thunk address

Catch:
  zError "zMap_hWnd", "Window handle isn't subclassed"
End Function

'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
  Dim bSub  As Byte                                                         'Value we expect to find pointed at by a vTable method entry
  Dim bVal  As Byte
  Dim nAddr As Long                                                         'Address of the vTable
  Dim i     As Long                                                         'Loop index
  Dim j     As Long                                                         'Loop limit
  
  RtlMoveMemory VarPtr(nAddr), ObjPtr(oCallback), 4                         'Get the address of the callback object's instance
  If Not zProbe(nAddr + &H1C, i, bSub) Then                                 'Probe for a Class method
    If Not zProbe(nAddr + &H6F8, i, bSub) Then                              'Probe for a Form method
      If Not zProbe(nAddr + &H7A4, i, bSub) Then                            'Probe for a UserControl method
        Exit Function                                                       'Bail...
      End If
    End If
  End If
  
  i = i + 4                                                                 'Bump to the next entry
  j = i + 1024                                                              'Set a reasonable limit, scan 256 vTable entries
  Do While i < j
    RtlMoveMemory VarPtr(nAddr), i, 4                                       'Get the address stored in this vTable entry
    
    If IsBadCodePtr(nAddr) Then                                             'Is the entry an invalid code address?
      RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
      Exit Do                                                               'Bad method signature, quit loop
    End If

    RtlMoveMemory VarPtr(bVal), nAddr, 1                                    'Get the byte pointed to by the vTable entry
    If bVal <> bSub Then                                                    'If the byte doesn't match the expected value...
      RtlMoveMemory VarPtr(zAddressOf), i - (nOrdinal * 4), 4               'Return the specified vTable entry address
      Exit Do                                                               'Bad method signature, quit loop
    End If
    
    i = i + 4                                                             'Next vTable entry
  Loop
End Function

'Probe at the specified start address for a method signature
Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
  Dim bVal    As Byte
  Dim nAddr   As Long
  Dim nLimit  As Long
  Dim nEntry  As Long
  
  nAddr = nStart                                                            'Start address
  nLimit = nAddr + 32                                                       'Probe eight entries
  Do While nAddr < nLimit                                                   'While we've not reached our probe depth
    RtlMoveMemory VarPtr(nEntry), nAddr, 4                                  'Get the vTable entry
    
    If nEntry <> 0 Then                                                     'If not an implemented interface
      RtlMoveMemory VarPtr(bVal), nEntry, 1                                 'Get the value pointed at by the vTable entry
      If bVal = &H33 Or bVal = &HE9 Then                                    'Check for a native or pcode method signature
        nMethod = nAddr                                                     'Store the vTable entry
        bSub = bVal                                                         'Store the found method signature
        zProbe = True                                                       'Indicate success
        Exit Function                                                       'Return
      End If
    End If
    
    nAddr = nAddr + 4                                                       'Next vTable entry
  Loop
End Function

Private Property Get zData(ByVal nIndex As Long) As Long
  RtlMoveMemory VarPtr(zData), z_ScMem + (nIndex * 4), 4
End Property

Private Property Let zData(ByVal nIndex As Long, ByVal nValue As Long)
  RtlMoveMemory z_ScMem + (nIndex * 4), VarPtr(nValue), 4
End Property

'-Subclass callback, usually ordinal #1, the last method in this source file----------------------
Private Sub zWndProc1(ByVal bBefore As Boolean, _
                      ByRef bHandled As Boolean, _
                      ByRef lReturn As Long, _
                      ByVal lng_hWnd As Long, _
                      ByVal uMsg As Long, _
                      ByVal wParam As Long, _
                      ByVal lParam As Long, _
                      ByRef lParamUser As Long)
'*************************************************************************************************
'* bBefore    - Indicates whether the callback is before or after the original WndProc. Usually
'*              you will know unless the callback for the uMsg value is specified as
'*              MSG_BEFORE_AFTER (both before and after the original WndProc).
'* bHandled   - In a before original WndProc callback, setting bHandled to True will prevent the
'*              message being passed to the original WndProc and (if set to do so) the after
'*              original WndProc callback.
'* lReturn    - WndProc return value. Set as per the MSDN documentation for the message value,
'*              and/or, in an after the original WndProc callback, act on the return value as set
'*              by the original WndProc.
'* lng_hWnd   - Window handle.
'* uMsg       - Message value.
'* wParam     - Message related data.
'* lParam     - Message related data.
'* lParamUser - User-defined callback parameter
'*************************************************************************************************
  Dim tLayered As Boolean

  If uMsg = WM_WINDOWPOSCHANGED Then                                        'Select the message number
    CopyMemory wp, ByVal lParam, Len(wp)                                    'Copy the WINDOWPOS data
    SizePos                                                                 'Position shadows

  ElseIf uMsg = WM_SIZE Then                                                'Parent form has been minimized/restored/maximized
    If wParam = SIZE_RESTORED Then                                          'If the parent has been restored
      If IsWindowVisible(hWndForm) = 1 Then                                 'If the parent is visible
        Show True                                                           'Show shadows
      End If
    End If

  ElseIf uMsg = WM_DISPLAYCHANGE Then                                       'The display settings have been changed
    tLayered = bIsLayered                                                   'Save the the existing layered status
    CheckEnvironment                                                        'Check OS, color depth etc.
    If tLayered Then                                                        'If we were layer enabled
      If Not bIsLayered Then                                                'But not anymore
        DestroyWindow hWndBt                                                'Get rid of the shadow
        DestroyWindow hWndRt                                                'Get rid of the shadow
      End If
     Else
      If bIsLayered Then                                                    'If we're now layered but previously weren't
        CreateWindows                                                       'Creates the shadow windows
        DisplayShadows                                                      'Display the shadows
        If IsWindowVisible(hWndForm) Then                                   'If the parent is visible
          Show True, True                                                   'Display the shadows
        End If
      End If
    End If

  ElseIf uMsg = WM_THEMECHANGED Then                                        'Windows XP theme has changed
    CheckEnvironment                                                        'Check OS, color depth etc.
    DisplayShadows                                                          'Display the shadows

  End If
End Sub