vbAccelerator - Contents of code file: fFadeRect.frm

VERSION 5.00
Begin VB.Form fFadeRect 
   BorderStyle     =   0  'None
   Caption         =   "Form2"
   ClientHeight    =   2070
   ClientLeft      =   4545
   ClientTop       =   5160
   ClientWidth     =   4620
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2070
   ScaleWidth      =   4620
   ShowInTaskbar   =   0   'False
End
Attribute VB_Name = "fFadeRect"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type SIZEAPI
   cx As Long
   cy As Long
End Type

Private Type POINTAPI
   x As Long
   y As Long
End Type

Private Type RECT
   left As Long
   top As Long
   right As Long
   bottom As Long
End Type

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

Private Const AC_SRC_OVER As Long = &H0&
Private Const ULW_COLORKEY As Long = &H1&
Private Const ULW_ALPHA As Long = &H2&
Private Const ULW_OPAQUE As Long = &H4&

Private Const WS_EX_TOPMOST As Long = &H8&
Private Const WS_EX_TRANSPARENT  As Long = &H20&
Private Const WS_EX_TOOLWINDOW As Long = &H80&
Private Const WS_EX_LAYERED As Long = &H80000
Private Const WS_POPUP = &H80000000
Private Const WS_VISIBLE = &H10000000
Private Const SPI_GETSELECTIONFADE As Long = &H1014&

Private Declare Function CreateWindowEX Lib "user32" Alias "CreateWindowExA"
 (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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias
 "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef
 lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hdcDst As Long, _
    pptDst As Any, _
    psize As Any, _
    ByVal hdcSrc As Long, _
    pptSrc As Any, _
    ByVal crKey As Long, _
    pblend As BLENDFUNCTION, _
    ByVal dwFlags As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As
 Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long

' Set the position of a window:
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
Private Const HWND_BOTTOM = 1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long

Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor
 As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Const CLR_NONE As Long = -1&

Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal
 lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As
 Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private WithEvents m_tmr As CTimer
Attribute m_tmr.VB_VarHelpID = -1

Private m_hWnd As Long
Private m_bAlpha As Byte
Private m_bFadeStepSize As Byte
Private m_bForceFade As Boolean
Private m_oTransparentColor As OLE_COLOR
Private m_lColor As Long
Private m_lFlags As Long

Public Property Get TransparentColor() As OLE_COLOR
   TransparentColor = m_oTransparentColor
End Property
Public Property Let TransparentColor(ByVal oColor As OLE_COLOR)
   m_oTransparentColor = oColor
End Property

Public Property Get ForceFade() As Boolean
   ForceFade = m_bForceFade
End Property
Public Property Let ForceFade(ByVal value As Boolean)
   m_bForceFade = value
End Property

Public Property Get FadeEffectsSelected() As Boolean
Dim lFade As Long
   SystemParametersInfo SPI_GETSELECTIONFADE, 0, lFade, 0
   FadeEffectsSelected = Not (lFade = 0)
End Property

Public Property Get FadeStepSize() As Byte
   FadeStepSize = m_bFadeStepSize
End Property
Public Property Let FadeStepSize(ByVal value As Byte)
   If (value < 1) Then
      Err.Raise 380, App.EXEName & ".fFadeRect", "FadeStepSize must be between
       1 and 255."
   Else
      m_bFadeStepSize = value
   End If
End Property

Public Sub FadeRect( _
      ByVal lSrcLeft As Long, _
      ByVal lSrcTop As Long, _
      ByVal lLeft As Long, _
      ByVal lTop As Long, _
      ByVal lWidth As Long, _
      ByVal lheight As Long, _
      Optional ByVal lhDCSrc As Long = 0 _
   )
Dim lFade As Long
Dim tSize As SIZEAPI
Dim tBlend As BLENDFUNCTION
Dim lBlend As Long
Dim tPtSrc As POINTAPI
Dim bDelDC As Boolean
Dim lhDC As Long
    
   ' // Be nice and respect the user's wishes: Do they want the fade?
   If Not m_bForceFade Then
      SystemParametersInfo SPI_GETSELECTIONFADE, 0, lFade, 0
      If (lFade = 0) Then
         Unload Me
         Exit Sub
      End If
   End If
   
   If (lhDCSrc = 0) Then
      lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
      bDelDC = True
   Else
      lhDC = lhDCSrc
   End If
   
   Me.Move lLeft * Screen.TwipsPerPixelX, lTop * Screen.TwipsPerPixelY
   SetWindowPos m_hWnd, HWND_TOPMOST, lLeft, lTop, 0, 0, SWP_NOACTIVATE Or
    SWP_SHOWWINDOW

   If Not (m_hWnd = 0) Then
      Dim tR As RECT
      GetWindowRect m_hWnd, tR
   
      tSize.cx = lWidth
      tSize.cy = lheight
   
      tPtSrc.x = lSrcLeft
      tPtSrc.y = lSrcTop
   
      m_bAlpha = 255
      tBlend.BlendOp = AC_SRC_OVER
      tBlend.BlendFlags = 0
      tBlend.AlphaFormat = 0
      tBlend.SourceConstantAlpha = m_bAlpha
      
      m_lColor = TranslateColor(m_oTransparentColor)
      m_lFlags = ULW_ALPHA
      If Not (m_oTransparentColor = CLR_NONE) Then
         m_lFlags = m_lFlags Or ULW_COLORKEY
      End If
      On Error Resume Next ' in case run on non-2k+ systems
      UpdateLayeredWindow m_hWnd, ByVal 0&, ByVal 0&, tSize, lhDC, tPtSrc,
       m_lColor, _
            tBlend, m_lFlags
    
      ' Finally set the animation timer
      Set m_tmr = New CTimer
      m_tmr.Interval = 25
   End If
   
   If bDelDC Then
      DeleteDC lhDCSrc
   End If
   
End Sub


Private Sub Form_Initialize()
   m_bFadeStepSize = 15
   m_oTransparentColor = vbButtonFace
End Sub

Private Sub Form_Load()
Dim lExStyle As Long
Dim lStyle As Long

   m_hWnd = Me.hwnd
   lExStyle = WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_TOPMOST Or
    WS_EX_TOOLWINDOW
   lStyle = WS_POPUP Or WS_VISIBLE
   SetWindowLong m_hWnd, GWL_STYLE, lStyle
   SetWindowLong m_hWnd, GWL_EXSTYLE, lExStyle
   
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y
 As Single)
   ' This won't happen since we've given the Window
   ' the WS_EX_TRANSPARENT style, which means it is
   ' invisible to mouse clicks.
   MsgBox "Clicked", vbExclamation
End Sub

Private Sub m_tmr_ThatTime()
Dim tBlend As BLENDFUNCTION
Dim lBlend As Long
   
   If (m_bAlpha >= m_bFadeStepSize) Then
      m_bAlpha = m_bAlpha - m_bFadeStepSize
      
      tBlend.BlendOp = AC_SRC_OVER
      tBlend.BlendFlags = 0
      tBlend.AlphaFormat = 0
      tBlend.SourceConstantAlpha = m_bAlpha
 
      On Error Resume Next ' for non-2k+ systems
      UpdateLayeredWindow m_hWnd, ByVal 0&, ByVal 0&, ByVal 0&, ByVal 0&, ByVal
       0&, _
                    ByVal 0&, tBlend, ULW_ALPHA
   Else
      ' complete
      Unload Me
      m_tmr.Interval = 0
      Set m_tmr = Nothing
   End If
   
End Sub


Private Function TranslateColor(ByVal oClr As OLE_COLOR, _
                                   Optional hPal As Long = 0) As Long
   ' Convert Automation color to Windows color
   If OleTranslateColor(oClr, hPal, TranslateColor) Then
       TranslateColor = -1
   End If
   
End Function