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

 

[Jeffrey Mahoney]

I tried it on my system. Nothing showed. Windows 7 64 - Office 2013

 

[Jaafar Tribak]

Hi Jeffrey - Thanks for testing the code.

Just a stab in dark, try replacing #If Win64 with #If VBA7 in both the module level declarations at the top and inside the Fade_In_Fade_Out_Text routine and see if it works on your system.

 

[Leith Ross]

Hello Jaafar,

I like what you have done. Nice work!

I have Windows 7 64 bit and had no problems. The message "Hello Owner" fades in fine but it did not fade out.

As a side note, to see the message you must run the macro from Excel using ALT+F8 and not in the VBA Editor. Otherwise it will appear that Excel is hung.

 

[Jeffrey Mahoney]

Thanks Jaafar. I made those changes. I've run it within the editor and from the macros dialog box. I still don't see anything. I did have to change the sound file that was suppose to play to something in my media folder. The macro runs for about 30 seconds in normal mode and about 15 seconds in fast mode.

Jeff

 

[Jaafar Tribak]

Really don't know why it is not working for you ..I tested the code on 2 different machines (Win 7 32bit Office 2007) and (Win 10 64bit Office 2010 64bit) and they both worked fine.. It could be a difference in the graphic card.

I am thinking of writing an alternative code to render the text on a transparent userform rather than on the screen so I can use the handy form Repaint Method.. Maybe, that would make the code more reliable.

 

[Hjemmet]

Nothing Shows in Office 2016 or 2019

 

[Jaafar Tribak]

Nothing Shows in Office 2016 or 2019

I'll try to update the code and see if it now works.

 

[Jaafar Tribak]

Workbook demo

 

[Hjemmet]

I have try the New Version And Nothing Happend

But Sound OK

windows 10 Pro Danish
Excel 2016 Danish