Fade_In_Fade_Out Text (Splash Screen Demo)

[Jaafar Tribak]

Hello,

Recently, I have been messing with some GDI APIs in order to be able to display a fading text on the screen and thought I would post here what I came up with. The challenge was to make the fading effect smooth without flickering.

In order to achieve a flicker-free fading text, the values of the font size and fading-speed arguments may need some tweaking when calling the Fade_In_Fade_Out_Text routine...The smaller the font, the better the result.

The routine takes an optional SoundFile argument so a wav file can be played while the splash screen is active.

Workbook demo

Code in a Standard Module : ( Press ESC or CTRL-BREAK keys to abort the code)

Option Explicit

Private Enum FadePace
    Normal = 1
    fast = 2
End Enum

Private Type Size
    cx As Long
    cy 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 Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 32
End Type

#If Win64 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As LongPtr
    Private Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
#End If

Private Const MM_TEXT = 1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_ASYNC = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const TRANSPARENT = 1
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const POINTS_PER_INCH = 72


Sub RunTest()

    Call Fade_In_Fade_Out_Text( _
        Text:="Hello " & Environ("username"), _
        FontName:="Forte", _
        FontSize:=80, _
        FontColour:=vbBlue, _
        FadeSpeed:=Normal, _
        SoundFile:="C:\WINDOWS\MEDIA\RING08.WAV")

End Sub


Private Sub Fade_In_Fade_Out_Text _
                                  ( _
    ByVal Text As String, _
    Optional ByVal FontName As String, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontColour As Long, _
    Optional ByVal FadeSpeed As FadePace, _
    Optional ByVal SoundFile As String _
                                                    )
                                                    
                                         
    #If Win64 Then
        Dim hdc As LongPtr, hMemDC1 As LongPtr, hMemDC2 As LongPtr
        Dim hFont As LongPtr, hNewFont As LongPtr, hOldFont As LongPtr
        Dim hBmp As LongPtr, hBmp2 As LongPtr
    #Else
        Dim hdc As Long, hMemDC1 As Long, hMemDC2 As Long
        Dim hFont As Long, hNewFont As Long, hOldFont As Long
        Dim hBmp As Long, hBmp2 As Long
    #End If
    
    Dim tLGF As LOGFONT
    Dim tTextSize As Size
    Dim tXLRect As RECT, tTextRect As RECT
    Dim BF As BLENDFUNCTION, lBF As Long
    Dim Wdth As Long, Hght As Long
    Dim I As Long, lSleep As Long
    Dim X1 As Long, Y1 As Double
   
    Application.EnableCancelKey = xlErrorHandler
    On Error GoTo Xit
    
    If FadeSpeed = Normal Or (FadeSpeed <> Normal And FadeSpeed <> fast) Then lSleep = 100
    If FadeSpeed = fast Then lSleep = 50
    
    If Len(Dir(SoundFile)) <> 0 Then
        PlaySoundAPI SoundFile, _
        ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP
    End If
    
    GetClientRect Application.hwnd, tXLRect
    hdc = GetDC(Application.hwnd)
    Call SetMapMode(hdc, MM_TEXT)
    hFont = CreateFont(-MulDiv(IIf(FontSize = 0, 50, FontSize), GetDeviceCaps(hdc, LOGPIXELSY), POINTS_PER_INCH), _
    0, 0, 0, 400, 0, 0, 0, 0, 0, 0, 0, 0, FontName & Chr$(0))
    DeleteObject SelectObject(hdc, hFont)
    Call GetTextExtentPoint32(hdc, Text, Len(Text), tTextSize)
    Wdth = tTextSize.cx * (POINTS_PER_INCH / GetDeviceCaps(hdc, LOGPIXELSX))
    Hght = tTextSize.cy * (POINTS_PER_INCH / GetDeviceCaps(hdc, LOGPIXELSY))
    X1 = ((tXLRect.Right - tXLRect.Left) - Wdth) / 2
    Y1 = ((tXLRect.Bottom - tXLRect.Top) - Hght) / 2
    hMemDC1 = CreateCompatibleDC(hdc)
    hBmp = CreateCompatibleBitmap(hdc, Wdth, Hght)
    DeleteObject SelectObject(hMemDC1, hBmp)
    Call SetMapMode(hMemDC1, MM_TEXT)
    Call SetBkMode(hMemDC1, TRANSPARENT)
    Call SetBkMode(hdc, TRANSPARENT)
    Call BitBlt(hMemDC1, 0, 0, Wdth, Hght, hdc, X1, Y1, SRCCOPY)
    With tLGF
        .lfHeight = IIf(FontSize = 0, 50, FontSize)
        .lfFaceName = FontName & Chr$(0)
    End With
    hNewFont = CreateFontIndirect(tLGF)
    DeleteObject SelectObject(hMemDC1, hNewFont)
    SetTextColor hMemDC1, FontColour
    SetRect tTextRect, 0, 0, Wdth, Hght
    DrawText hMemDC1, Text, Len(Text), tTextRect, DT_CENTER + DT_VCENTER  '+ DT_WORDBREAK
    hMemDC2 = CreateCompatibleDC(hdc)
    hBmp2 = CreateCompatibleBitmap(hdc, Wdth, Hght)
    DeleteObject SelectObject(hMemDC2, hBmp2)
    Call SetBkMode(hMemDC2, TRANSPARENT)
    Call BitBlt(hMemDC2, 0, 0, Wdth, Hght, hdc, X1, Y1, SRCCOPY)

    For I = 0 To 254 Step 2
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = I
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        AlphaBlend hdc, X1, Y1, Wdth, Hght, hMemDC1, 0, 0, Wdth, Hght, (lBF)
        Sleep lSleep
        Call BitBlt(hdc, X1, Y1, Wdth, Hght, hMemDC2, 0, 0, SRCCOPY)
    Next I
    
    For I = 254 To 0 Step -2
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = I
            .AlphaFormat = 0
        End With
        CopyMemory lBF, BF, 4
        AlphaBlend hdc, X1, Y1, Wdth, Hght, hMemDC1, 0, 0, Wdth, Hght, (lBF)
        Sleep lSleep
        Call BitBlt(hdc, X1, Y1, Wdth, Hght, hMemDC2, 0, 0, SRCCOPY)
    Next I
    Sleep 1000
Xit:
    InvalidateRect 0, 0, 0
    PlaySoundAPI vbNullString, 0, 0
    ReleaseDC Application.hwnd, hdc
    DeleteDC hMemDC1
    DeleteDC hMemDC2
    DeleteObject hBmp
    DeleteObject hBmp2
    DeleteObject hNewFont
    DeleteObject hFont
    If Err <> 0 And Err <> 18 Then MsgBox Err.Description, vbCritical, "error: " & Err.Number
End Sub

 

[Jaafar Tribak]

I have try the New Version And Nothing Happend

But Sound OK

windows 10 Pro Danish
Excel 2016 Danish

Honestly, I don't know why it works in some computers and doesn't on others.

I have revised the code but couldn't find any potential cause of the issue.

 

[Dan_W]

Hi Jaafar. I appreciate that this post is 1058 days old, but I thought it might be helpful to someone if I post a partial (possible) solution.

Like the Jeffrey and Hjemmet, I've not been able to get to this work to-date. I hear the music, and that's it. I stepped through the code, but with my meagre experience with GDI APIs, nothing obvious jumped out at me.

It does, however, work perfectly (for me, at least) when I change the hWnd to that of a Userform and not the Application itself. Forgive me if you've already solved this issue in a later post and I'm telling you something you already know (I checked but couldn't find anything).

For your reference, I use Office 365 64bit + Windows 10.

 

[Jaafar Tribak]

Hi Jaafar. I appreciate that this post is 1058 days old, but I thought it might be helpful to someone if I post a partial (possible) solution.

Like the Jeffrey and Hjemmet, I've not been able to get to this work to-date. I hear the music, and that's it. I stepped through the code, but with my meagre experience with GDI APIs, nothing obvious jumped out at me.

It does, however, work perfectly (for me, at least) when I change the hWnd to that of a Userform and not the Application itself. Forgive me if you've already solved this issue in a later post and I'm telling you something you already know (I checked but couldn't find anything).

For your reference, I use Office 365 64bit + Windows 10.

Hi Dan_W,

I haven't solved this issue ... I will try taking a fresh look at the code when I get some free time.

Regards.

 

[Jaafar Tribak]

Hi Jaafar. I appreciate that this post is 1058 days old, but I thought it might be helpful to someone if I post a partial (possible) solution.

Like the Jeffrey and Hjemmet, I've not been able to get to this work to-date. I hear the music, and that's it. I stepped through the code, but with my meagre experience with GDI APIs, nothing obvious jumped out at me.

It does, however, work perfectly (for me, at least) when I change the hWnd to that of a Userform and not the Application itself. Forgive me if you've already solved this issue in a later post and I'm telling you something you already know (I checked but couldn't find anything).

For your reference, I use Office 365 64bit + Windows 10.

I had a chance to revise the code over the week-end. I am still not sure if the issue with drawing directly onto the excel screen is due to some change introduced in office\excel 2013 and onwards or due to the Aero theme introduced with windows vista and later versions.

See if this workaround works for you (It worked for me nicely)
File Demo:
SplashScreen.xls

Note: Hold the ESC key down should you want to abort\stop the splash screen.


Here is the code which uses a win32 built-in static control as the drawing canvas:
1- In a Standard Module:

Option Explicit

'//////////////////////////////////////////////////////////////////
'    (FADE-IN\FADE-OUT) Splash Screen.
'    ESC Key To ABORT.
'/////////////////////////////////////////////////////////////////

Private Enum FadePace
    Slow = 1
    Fast = 2
End Enum

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type Size
    cx As Long
    cy As Long
End Type

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

Private Type Msg
    #If Win64 Then
        hwnd As LongLong
        Message As Long
        wParam As LongLong
        lParam As LongLong
    #Else
        hwnd As Long
        Message As Long
        wParam As Long
        lParam As Long
    #End If
    time As Long
    pt As POINTAPI
End Type

Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * 32
End Type

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

Private Type WINDOW_INFO
    #If Win64 Then
        hwnd As LongLong
        hDc As LongLong
        hScrDc As LongLong
        hMemDC1 As LongLong
        hMemDC2 As LongLong
        hBmp1 As LongLong
        hBmp2 As LongLong
        hFont As LongLong
    #Else
        hwnd As Long
        hDc As Long
        hScrDc As Long
        hMemDC1 As Long
        hMemDC2 As Long
        hBmp1 As Long
        hBmp2 As Long
        hFont As Long
    #End If
    Wdth As Long
    Hght As Long
    Delay As Single
    Text As String
    FontName As String
    FontSize As Single
    FontColour As Long
    FadeSpeed As FadePace
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    #End If
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDc As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hDc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function AlphaBlend Lib "msimg32.dll" (ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDc As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As LongPtr, ByVal lpClassName As LongPtr, ByVal lpWindowName As LongPtr, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, ByRef lpParam As Any) As LongPtr
    Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal pModuleName As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
    Private Declare PtrSafe Function UnregisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long) As Long
    Private Declare PtrSafe Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    Private Declare PtrSafe Function RegisterHotKey Lib "user32" (ByVal hwnd As LongPtr, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As LongPtr)
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
  
    Private lPrevStaticProc As LongPtr
  
#Else
    Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal hDc As Long, ByVal nMapMode As Long) As Long
    Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hDc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
    Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hDc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
    Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
    Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, 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, ByRef lpParam As Any) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal pModuleName As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetFocus Lib "user32" () As Long
    Private Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long) As Long
    Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    Private Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  
    Private lPrevStaticProc As Long

#End If


Private tINFO As WINDOW_INFO
Private bAbortLoop As Boolean
Private bLooping As Boolean
Private bIsActive As Boolean
Private bClosing As Boolean
Private lPrevAlpha As Long
Private sSoundFile As String


Public Sub RunTest()

    Call Fade_In_Fade_Out_Text( _
        Text:="Hello " & "MrExcel", _
        FontName:="Forte", _
        FontSize:=120, _
        FontColour:=vbBlue, _
        FadeSpeed:=Slow, _
        SoundFile:="C:\WINDOWS\MEDIA\RING08.WAV")

End Sub


'________________________________________________PUBLIC ROUTINE________________________________________________

'
Public Sub UnSubClass(Optional ByVal Dummy As Boolean)

' \\ Safety routine ran in the Workbook_BeforeClose event !!!

    Const GWL_WNDPROC = -4
    #If Win64 Then
        Dim hwnd As LongLong, lPrevProc As LongLong
    #Else
            Dim hwnd As Long, lPrevProc As Long
    #End If
  
    hwnd = GetProp(Application.hwnd, "STATIC")
    lPrevProc = GetProp(Application.hwnd, "PREVPROC")
  
    If IsWindow(hwnd) Then
        Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevProc)
        Call DestroyWindow(hwnd)
    End If

End Sub


'________________________________________________PRIVATE ROUTINES________________________________________________

Private Sub Fade_In_Fade_Out_Text( _
    ByVal Text As String, _
    Optional ByVal FontName As String, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontColour As Long, _
    Optional ByVal FadeSpeed As FadePace, _
    Optional ByVal SoundFile As String _
    )
  
    Const KEYEVENTF_EXTENDEDKEY = &H1
    Const KEYEVENTF_KEYUP = &H2
    Const VK_ESCAPE = &H1B
    Const WH_CBT = 5
  
    Application.EnableCancelKey = xlDisabled
    On Error GoTo Xit
  
    If bLooping Then Exit Sub
    If tINFO.hwnd Then Exit Sub
    tINFO = CreateWindow(Text, FontName, FontSize, FontColour, FadeSpeed, SoundFile)
    If tINFO.hwnd = 0 Then MsgBox "Error!" & vbNewLine & "Unable to create window": Exit Sub
  
    bClosing = False

    Call keybd_event(VK_ESCAPE, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(VK_ESCAPE, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    DoEvents

    EnableESCKey = True
  
    If Len(Dir(SoundFile)) Then
        sSoundFile = SoundFile
        Call PlaySound(SoundFile)
    End If
  
    Call DoFadeInFadeOut(True)
    Call DoFadeInFadeOut(False)
  
Xit:
    bClosing = False
    bIsActive = False
    bLooping = False
    bAbortLoop = False
    lPrevAlpha = 0
    Call PlaySound(SoundFile, False)
    EnableESCKey = False
    Call ClearUpWindowInfo(tINFO)
  
    If Err.Number And Err.Number <> 18 Then MsgBox Err.Description, vbCritical, "error: " & Err.Number
  
End Sub


Private Function CreateWindow( _
        ByVal Text As String, _
        Optional ByVal FontName As String, _
        Optional ByVal FontSize As Long, _
        Optional ByVal FontColour As Long, _
        Optional ByVal FadeSpeed As FadePace, _
        Optional ByVal SoundFile As String _
    ) As WINDOW_INFO
  
  
    Const WS_VISIBLE = &H10000000
    Const WS_POPUP = &H80000000
    Const WS_EX_NOACTIVATE = &H8000000
    Const WS_EX_TOPMOST = &H8&
    Const WM_SETREDRAW = &HB
    Const SRCCOPY = &HCC0020
    Const SM_CXSCREEN = 0
    Const SM_CYSCREEN = 1
    Const MM_TEXT = 1
    Const TRANSPARENT = 1
    Const DT_CENTER = &H1
    Const DT_VCENTER = &H4
    Const GWL_WNDPROC = -4

  
    #If Win64 Then
        Dim hStatic As LongLong
        Dim hDc As LongLong, hScrDc As LongLong, hFont As LongLong, hPrevFont As LongLong
        Dim hMemDC1 As LongLong, hMemDC2 As LongLong
        Dim hBmp1 As LongLong, hBmp2 As LongLong
    #Else
        Dim hStatic As Long
        Dim hDc As Long, hScrDc As Long, hFont As Long, hPrevFont As Long
        Dim hMemDC1 As Long, hMemDC2 As Long
        Dim hBmp1 As Long, hBmp2 As Long
    #End If

    Dim tFont As LOGFONT, tTextSize As Size, tTextRect As RECT
    Dim BF As BLENDFUNCTION, lBF As Long
    Dim Wdth As Long, Hght As Long
    Dim i As Long, x As Long, y As Long
    Dim lStyles As Long, lExStyles As Long
    Dim sngDelay As Single
  
 
    Application.EnableCancelKey = xlDisabled
    On Error GoTo Xit
  
    If FadeSpeed = Slow Or (FadeSpeed <> Slow And FadeSpeed <> Fast) Then sngDelay = 0.15
    If FadeSpeed = Fast Then sngDelay = 0.06
  
    Call Sleep(100)
  
    lStyles = WS_VISIBLE + WS_POPUP:    lExStyles = WS_EX_TOPMOST + WS_EX_NOACTIVATE
    hStatic = CreateWindowEx(lExStyles, StrPtr("STATIC"), StrPtr(""), lStyles, 0, 0, 0, 0, 0, 0, GetModuleHandle(StrPtr(vbNullString)), 0)
  
    lPrevStaticProc = SetWindowLong(hStatic, GWL_WNDPROC, AddressOf StaticProc)
  
    Call SetProp(Application.hwnd, "PREVPROC", lPrevStaticProc)
    Call SetProp(Application.hwnd, "STATIC", hStatic)
  
    hDc = GetDC(hStatic)
    hScrDc = GetDC(0)
    Call SetMapMode(hDc, MM_TEXT)
    With tFont
        .lfHeight = IIf(FontSize = 0, 50, FontSize)
        .lfFaceName = FontName & Chr$(0)
    End With
    hFont = CreateFontIndirect(tFont)
    hPrevFont = SelectObject(hDc, hFont)
    Call GetTextExtentPoint32(hDc, Text, Len(Text), tTextSize)
    Wdth = tTextSize.cx
    Hght = tTextSize.cy
    Call SetRect(tTextRect, 0, 0, Wdth, Hght)
    Call SelectObject(hDc, hPrevFont)
    x = (GetSystemMetrics(SM_CXSCREEN) - Wdth) / 2
    y = (GetSystemMetrics(SM_CYSCREEN) - Hght) / 2
  
    hMemDC1 = CreateCompatibleDC(hDc)
    hBmp1 = CreateCompatibleBitmap(hDc, Wdth, Hght)
    Call SelectObject(hMemDC1, hBmp1)
    Call SetMapMode(hMemDC1, MM_TEXT)
    Call SetBkMode(hMemDC1, TRANSPARENT)
    Call SetBkMode(hDc, TRANSPARENT)
    Call BitBlt(hMemDC1, 0, 0, Wdth, Hght, hScrDc, x, y, SRCCOPY)
    hPrevFont = SelectObject(hMemDC1, hFont)
    Call SetTextColor(hMemDC1, FontColour)
    Call DrawText(hMemDC1, Text, Len(Text), tTextRect, DT_CENTER + DT_VCENTER)
    Call SelectObject(hMemDC1, hPrevFont)
    Call DeleteObject(hFont)
  
    hMemDC2 = CreateCompatibleDC(hDc)
    hBmp2 = CreateCompatibleBitmap(hDc, Wdth, Hght)
    Call SelectObject(hMemDC2, hBmp2)
    Call SetBkMode(hMemDC2, TRANSPARENT)
    Call BitBlt(hMemDC2, 0, 0, Wdth, Hght, hScrDc, x, y, SRCCOPY)
  
    Call SendMessage(hStatic, ByVal WM_SETREDRAW, ByVal 0, 0)
    Call MoveWindow(hStatic, x, y, Wdth, Hght, 1)
    Call SendMessage(hStatic, ByVal WM_SETREDRAW, ByVal 1, 0)
  
    With tINFO
        .hwnd = hStatic
        .hDc = hDc
        .hScrDc = hScrDc
        .hMemDC1 = hMemDC1
        .hMemDC2 = hMemDC2
        .hBmp1 = hBmp1
        .hBmp2 = hBmp2
        .hFont = hFont
        .Wdth = Wdth
        .Hght = Hght
        .Delay = sngDelay
        .Text = Text
        .FontName = FontName
        .FontSize = FontSize
        .FontColour = FontColour
        .FadeSpeed = FadeSpeed
    End With
  
    CreateWindow = tINFO
  
    Exit Function
Xit:
bLooping = False

    Call ClearUpWindowInfo(tINFO)

End Function



Private Sub DoFadeInFadeOut(ByVal FadeIn As Boolean)

    Const WM_SETREDRAW = &HB
    Const AC_SRC_OVER = &H0
    Const SRCCOPY = &HCC0020

    Dim BF As BLENDFUNCTION, lBF As Long
    Dim oPrevVisibleRange As Range
    Dim tPrevXLRect As RECT, tCurXLRect As RECT
    Dim lAlpha As Long, lMaxLoop As Long, lAlphaValue As Long, lStep As Long

    If FadeIn Then
        lMaxLoop = 254
        lAlphaValue = lPrevAlpha
        lStep = 4
    Else
        lPrevAlpha = 0
        lMaxLoop = 0
        lAlphaValue = 254 - lPrevAlpha
    lStep = -4
    End If
  
    If bAbortLoop Then Exit Sub
    Call GetWindowRect(Application.hwnd, tPrevXLRect)
    Set oPrevVisibleRange = ActiveWindow.VisibleRange
  
    With tINFO
        For lAlpha = lAlphaValue To lMaxLoop Step lStep
            bLooping = True
            Call GetWindowRect(Application.hwnd, tCurXLRect)
            If ActiveWindow.VisibleRange.Address <> oPrevVisibleRange.Address Or _
                EqualRect(tPrevXLRect, tCurXLRect) = 0 And bClosing = False Then
                lPrevAlpha = lAlpha
                Set oPrevVisibleRange = Application.ActiveWindow.VisibleRange
                Call GetWindowRect(Application.hwnd, tPrevXLRect)
                Call ClearUpWindowInfo(tINFO)
                tINFO = CreateWindow(.Text, .FontName, .FontSize, .FontColour, .FadeSpeed)
                Call SendMessage(.hwnd, ByVal WM_SETREDRAW, ByVal 1, 0)
                End If
            Call CopyMemory(lBF, BF, LenB(BF))
            With BF
                .BlendOp = AC_SRC_OVER
                .BlendFlags = 0
                .SourceConstantAlpha = lAlpha
            .AlphaFormat = 0
            End With
            Call BitBlt(.hDc, 0, 0, .Wdth, .Hght, .hMemDC2, 0, 0, SRCCOPY)
            Call AlphaBlend(.hDc, 0, 0, .Wdth, .Hght, .hMemDC1, 0, 0, .Wdth, .Hght, lBF)
            If lAlpha < 254 Then
                Call Delay(tINFO, RegisterWindowMessage("Dummy"))
                If bAbortLoop Then
                    Exit Sub
                End If
            End If
        Next lAlpha
    End With
  
End Sub

  
Private Sub Delay(ByRef INFO As WINDOW_INFO, ByVal DummyMsg As Long)

    Const PM_NOREMOVE = &H0
    Const WM_HOTKEY = &H312
  
    Dim tMSG As Msg
    Dim sTmr As Single
  
    sTmr = Timer
    Do
        Call PostMessage(INFO.hwnd, DummyMsg, 0, 0)
        Call WaitMessage
        If PeekMessage(tMSG, 0, WM_HOTKEY, WM_HOTKEY, PM_NOREMOVE) Then
                bAbortLoop = True: DoEvents:
                ClearUpWindowInfo tINFO
                Exit Do
        End If
        Call ToggleVisible(INFO.hwnd)
        DoEvents
    Loop Until Timer - sTmr > INFO.Delay Or bClosing
  
End Sub


Private Property Let EnableESCKey(ByVal bEnable As Boolean)
    Const VK_ESCAPE = &H1B
    If bEnable Then
        Call RegisterHotKey(0, &HBFFF&, 0, VK_ESCAPE)
    Else
        Call UnregisterHotKey(0, &HBFFF&)
    End If
End Property


#If Win64 Then
    Private Sub ToggleVisible(hwnd As LongLong)
#Else
    Private Sub ToggleVisible(hwnd As Long)
#End If

    Const SW_HIDE = 0
    Const SW_NORMAL = 1

    If IsIconic(Application.hwnd) Then
        Call ShowWindow(hwnd, SW_HIDE)
        bIsActive = False
    End If
    If GetFocus = hwnd Or GetForegroundWindow = Application.hwnd And bIsActive = False Then
        bIsActive = True
        Call ShowWindow(hwnd, SW_NORMAL)
    Else
        bIsActive = False
        Call ShowWindow(hwnd, SW_HIDE)
    End If

End Sub


Private Sub PlaySound(ByVal SoundFile As String, Optional ByVal Play As Boolean = True)

    Const SND_FILENAME = &H20000
    Const SND_LOOP = &H8
    Const SND_ASYNC = &H1
  
    If Play Then
        If Len(Dir(SoundFile)) <> 0 Then
            Call PlaySoundAPI(SoundFile, ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP)
        End If
     Else
        Call PlaySoundAPI(vbNullString, 0, 0)
    End If

End Sub

#If Win64 Then
    Private Function StaticProc(ByVal hwnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function StaticProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const GWL_WNDPROC = -4
    Const WM_KILLFOCUS = &H8
    Const WM_DESTROY = &H2

    Select Case Msg
        Case WM_KILLFOCUS
            Call ShowWindow(tINFO.hwnd, 0)
        Case WM_DESTROY
    End Select
 
    StaticProc = CallWindowProc(lPrevStaticProc, hwnd, Msg, wParam, ByVal lParam)

End Function


Private Sub ClearUpWindowInfo(ByRef INFO As WINDOW_INFO)
    Const GWL_WNDPROC = -4
    With INFO
        Call DeleteObject(.hBmp1)
        Call DeleteObject(.hBmp2)
        Call ReleaseDC(.hwnd, .hDc)
        Call ReleaseDC(0, .hScrDc)
        Call DeleteObject(.hFont)
        Call DeleteDC(.hMemDC1)
        Call DeleteDC(.hMemDC2)
        Call SetWindowLong(.hwnd, GWL_WNDPROC, lPrevStaticProc)
        Call DestroyWindow(.hwnd)
        .hwnd = 0
        .Delay = 0
        .Wdth = 0
        .Hght = 0
    End With
End Sub

2- Code in the ThisWorkbook Module, needed for safely unsubclassing the static control should the user accidently close the workbook while the splash screen is still running.

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    '\\ Safety routinne.
    Call UnSubClass
End Sub

Note:
The static control used here doesn't look like a control. It looks transparent and the user will only see the fading splash screen text.

Also, since the control has the WS_POPUP style bit set, it is always displayed relative to the computer screen (not to the excel window).... The code continiously monitors which window is currently in the foreground and toggles the control visibility accordingly.

 

[orsm6]

this worked for me on win 10 office 365. I have dual monitors, the sheet was open on monitor 2 but played the message on primary screen 1.

 

[Jaafar Tribak]

this worked for me on win 10 office 365. I have dual monitors, the sheet was open on monitor 2 but played the message on primary screen 1.

I can't test that since I have only one monitor.

Try this and see what happens :


1- Add this new API declaraion at the top of the module :

#If VBA7 Then
    Private Declare PtrSafe Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As LongPtr
#Else
    Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Long) As Long
#End If

2- In the CreateWindow function:
Replace this line :

 hScrDc = GetDC(0)

With this line:

hScrDc = CreateDC("DISPLAY", 0, 0, 0)

3- In the ClearUpWindowInfo Sub :
Replace this line :

Call ReleaseDC(0, .hScrDc)

With this line:

Call DeleteDC(hScrDc)

 

[Dan_W]

Hi Jaafar. I can confirm that this works for me now - the music plays and now I can see the text fade in and out on the screen regardless of the application's location / dimensions. As ever, I've learnt alot - thank you.

 

[Jaafar Tribak]

Hi Jaafar. I can confirm that this works for me now - the music plays and now I can see the text fade in and out on the screen regardless of the application's location / dimensions. As ever, I've learnt alot - thank you.

Glad the code worked for you and thanks for the feedback