Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,806
- Office Version
- 2016
- Platform
- Windows
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)
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)
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
