Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,807
- Office Version
- 2016
- Platform
- Windows
WARNING: This may crash your application so save your work before running the Demo workbook or trying the code
Hi there,
Following is a custom Msgbox Class. It is actually entirely based on the standard MsgBox but offers so much more control such us colors,fonts,timer...etc
What is nice about this custom MsgBox is that once you create a new instance of the class it is very easy to set all its attributes taking advantage of the VBE IntelliSense.
Be careful if you ever decide to edit the Class as it was a nightmare editing\debugging the code.( In so doing I crashed the App so many times that I've actually lost count
) - So, ensure you save your work !
Anyway,here is a workbook Demo : http://www.savefile.com/files/5199266
...and in case the above workbook link is ever broken, here is the ugly , overwhelming code behind the custom MsgBx:
1-In a Class Module named : clss_CustomMsgbx
2-In a Standard Module (holds all API declarations & Structs)
3-In another Standard Module (to run Hook & Subclassing Procs)
4-Yet, in another Standard Module (to run supporting routines)
5-In a last Standard Module for using the Class :
One nice missing feature is to be able to make the MsgBox Modeless.Unfortunately, I just can't seem to make it work...maybe someday or someone will find the solution
I have only tried the code in XL2002 so I am not sure if it will work for other versions.
Regards.
Hi there,
Following is a custom Msgbox Class. It is actually entirely based on the standard MsgBox but offers so much more control such us colors,fonts,timer...etc
What is nice about this custom MsgBox is that once you create a new instance of the class it is very easy to set all its attributes taking advantage of the VBE IntelliSense.
Be careful if you ever decide to edit the Class as it was a nightmare editing\debugging the code.( In so doing I crashed the App so many times that I've actually lost count
) - So, ensure you save your work !Anyway,here is a workbook Demo : http://www.savefile.com/files/5199266
...and in case the above workbook link is ever broken, here is the ugly , overwhelming code behind the custom MsgBx:
1-In a Class Module named : clss_CustomMsgbx
Code:
Private strPrompt, strTitle, strHelpFile As String
Private lngContext As Long
Private lngButtons As VbMsgBoxStyle
Private blnFlashTitle, blnScrollText As Boolean
Private blnFontItalic, blnFontBold As Boolean
Private Type PropSetByUser
BackColor As Boolean
FontColor As Boolean
FontZise As Boolean
Title As Boolean
FontItalic As Boolean
FontName As Boolean
ScrollText As Boolean
FlashTitle As Boolean
SetPosition As Boolean
Animation As Boolean
Prompt As Boolean
End Type
Private tPropSetByUser As PropSetByUser
Property Let FontName(ByVal vNewValue As String)
tPropSetByUser.FontName = True
g_strFontName = vNewValue
End Property
Property Let FontSize(ByVal vNewValue As Long)
tPropSetByUser.FontZise = True
g_lngFontSize = vNewValue
End Property
Property Let FontColor(ByVal vNewValue As Colors)
tPropSetByUser.FontColor = True
g_FontColor = vNewValue
End Property
Property Let FontBold(ByVal vNewValue As Boolean)
g_blnFontBold = vNewValue
End Property
Property Let BackColor(ByVal vNewValue As Colors)
tPropSetByUser.BackColor = True
g_BackColor = vNewValue
End Property
Property Let FontItalic(ByVal vNewValue As Boolean)
tPropSetByUser.FontItalic = True
g_blnFontItalic = vNewValue
End Property
Public Property Let Prompt(ByVal vNewValue As String)
tPropSetByUser.Prompt = True
g_StrPrompt = vNewValue
End Property
Property Let Buttons(ByVal vNewValue As VbMsgBoxStyle)
lngButtons = vNewValue
End Property
Property Let Title(ByVal vNewValue As String)
tPropSetByUser.Title = True
strTitle = vNewValue
End Property
Property Let HelpFile(ByVal vNewValue As String)
strHelpFile = vNewValue
End Property
Property Let Context(ByVal vNewValue As Long)
lngContext = vNewValue
End Property
Sub PlaySound(strSoundFile As String)
Call PlaySoundNow(strSoundFile)
End Sub
Public Sub Speak(strText As String)
Call SpeakText(strText)
End Sub
Property Let TimeOut(ByVal vNewValue As Long)
Call StartCountDown(vNewValue)
End Property
Property Let FlashTitle(ByVal vNewValue As Boolean)
g_blnFlashTitle = vNewValue
tPropSetByUser.FlashTitle = True
End Property
Property Let ScreenPos(ByVal vNewValue As ScreenPosition)
tPropSetByUser.SetPosition = True
g_ScreenPos = vNewValue
End Property
Property Let Animation(ByVal vNewValue As Animate)
tPropSetByUser.Animation = True
g_Animation = vNewValue
End Property
Sub ScrollText(Speed As ScrollSpeed)
tPropSetByUser.ScrollText = True
g_blnScrollText = True
g_Speed = Speed
Call ScrollTextProc
End Sub
Private Sub SetDefaults()
With tPropSetByUser
If Not .BackColor Then g_BackColor = GetSysColor(COLOR_BTNFACE)
If Not .FontColor Then g_FontColor = GetSysColor(COLOR_BTNTEXT)
If Not .FontZise Then g_lngFontSize = 10
If Not .FontItalic Then g_blnFontItalic = False
If Not .Animation Then g_Animation = NoAnimation
If Not .Prompt Then g_StrPrompt = ""
If Not .Title Then strTitle = Application.Name
If Not .FontName Then g_strFontName = "MS SANS SERIF"
If Not .ScrollText Then g_blnScrollText = False
If Not .FlashTitle Then g_blnFlashTitle = False
If Not .SetPosition Then g_ScreenPos = ScreenPosition.Centered
End With
If g_lngFontSize >= 15 Then g_StrPrompt = _
g_StrPrompt & vbNullString & vbCrLf & Space(1)
End Sub
Function Show() As Long
Call SetDefaults
Call InstallHooks
Show = MsgBox(g_StrPrompt, lngButtons, strTitle, strHelpFile, lngContext)
Call Un_InstallHooks
Call KillTimers
Call StopSound
End Function2-In a Standard Module (holds all API declarations & Structs)
Code:
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
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
Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
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
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Declare Function killtimerAPI Lib "user32" Alias "KillTimer" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function GetWindowThreadProcessId Lib "user32" _
(ByVal hwnd As Long, lpdwProcessId As Long) As Long
Declare Function sndPlaySound Lib "Winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundname As String, _
ByVal uFlags As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function FlashWindowEx Lib "user32" (pfwi As FLASHWINFO) As Boolean
Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String) As Long
Declare Sub keybd_event Lib "user32.dll" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function AnimateWindow Lib "user32" _
(ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hwnd As Long
End Type
Public Enum Colors
white = vbWhite
Black = vbBlack
Green = vbGreen
Blue = vbBlue
Red = vbRed
yellow = vbYellow
Magenta = vbMagenta
Cyan = vbCyan
Brown = &H3399
End Enum
Public Type FLASHWINFO
cbSize As Long
hwnd As Long
dwFlags As Long
uCount As Long
dwTimeout As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Enum ScreenPosition
Centered = 1
ToTheLeft = 2
ToTheRight = 3
Atthetop = 4
AtTheBottom = 5
TopLeft = 6
TopRight = 7
BottomLeft = 8
BottomRight = 9
End Enum
Public Enum Animate
NoAnimation = 0
HorRoll = &H2 'AW_HOR_NEGATIVE 'AW_HOR_NEGATIVE
VerRoll = &H4 'AW_VER_POSITIVE
Fade = &H10 'AW_CENTER
Blend = &H80000 'AW_BLEND
End Enum
Public Enum ScrollSpeed
high = 1
Medium = 2
low = 3
End Enum
Public Const COLOR_BTNFACE = 15
Public Const COLOR_BTNTEXT = 18
Public Const WM_GETFONT = &H31
Public Const SWP_FRAMECHANGED = &H20
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const WH_CALLWNDPROC = 4
Public Const WH_CBT = 5
Public Const GWL_WNDPROC = (-4)
Public Const WM_CREATE = &H1
Public Const WM_CTLCOLORBTN = &H135
Public Const WM_CTLCOLORDLG = &H136
Public Const WM_CTLCOLORSTATIC = &H138
Public Const WM_DESTROY = &H2
Public Const WM_SHOWWINDOW = &H18
Public Const GWL_HINSTANCE = (-6)
Public Const HCBT_ACTIVATE = 5
Public Const HC_ACTION = 0
Public Const AW_HOR_NEGATIVE = &H2
Public Const AW_VER_POSITIVE = &H4
Public Const AW_CENTER = &H10
Public Const AW_BLEND = &H80000
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Public Const SWP_NOACTIVATE = &H10
Public Const FLASHW_TIMER = &H4
Public Const FLASHW_CAPTION = &H1
Public Const FLASHW_STOP = 0
Public Const SND_LOOP = &H8
Public Const SND_ASYNC = &H1
Public Const SND_NODEFAULT = &H2
Public Const KEYEVENTF_EXTENDEDKEY = &H1
Public Const KEYEVENTF_KEYUP = &H2
Public lngHook As Long
Public lngHook2 As Long
Public lPrevWnd As Long
Public lngTimerID2 As Long
Public lngHwnd2 As Long
Public lngScrollCounter As Long
Public lngCycle As Long
Public strSoundFile As String
Public lngwParam As Long
Public lngTimeOut As Long
Public lngMsbxHwnd As Long
Public lngTimerID As Long
Public lngCounter As Long
Public lngStaticTextHwnd As Long
Public g_blnScrollText As Boolean
Public g_lngFontSize As Long
Public g_strFontName As String
Public g_blnFontItalic As Boolean
Public g_blnFontBold As Boolean
Public g_FontColor As Colors
Public g_BackColor As Colors
Public g_StrPrompt As String
Public g_blnFlashTitle As Boolean
Public g_lngTimeOut As Long
Public g_ScreenPos As ScreenPosition
Public g_Animation As Animate
Public g_Speed As ScrollSpeed
'-----------------------------------------------------------------3-In another Standard Module (to run Hook & Subclassing Procs)
Code:
'Option Explicit
Public Function HookWindows _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tCWP As CWPSTRUCT
Dim strClass As String
CopyMemory tCWP, ByVal lParam, Len(tCWP)
'detect when a window is created
If tCWP.message = WM_CREATE Then
strClass = Space(255)
strClass = Left(strClass, GetClassName(tCWP.hwnd, ByVal strClass, 255))
'if our window is a MsgBx subclass it
If strClass = "#32770" Then
lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf MsgBoxCallBack)
Call UnhookWindowsHookEx(lngHook) ': Exit Function
End If
End If
'allow other installed hooks if any
HookWindows = CallNextHookEx(lngHook, nCode, wParam, ByVal lParam)
End Function
'________________________________________________________________________________________
Public Function MsgBoxCallBack _
(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tLB As LOGBRUSH
Dim lFont As Long
'store this parameter in a Public var for later use
lngwParam = wParam
Select Case Msg
'position & animate MsgBx upon showing up
Case WM_SHOWWINDOW
Call PositionMsgBox(hwnd)
If Not g_Animation Then
Call Animate_Window(hwnd)
End If
'trap these Msgs to set the MsgBx colors
Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC, WM_CTLCOLORBTN
Call SetTextColor(lngwParam, g_FontColor)
Call SetBkColor(lngwParam, g_BackColor)
If Msg = WM_CTLCOLORSTATIC Then
' lFont = CreateFont(((g_lngFontSize / 72) * 96)
lFont = CreateFont((g_lngFontSize) _
, 0, 0, 0, IIf(g_blnFontBold, 1, 0), _
IIf(g_blnFontItalic, 1, 0), 0, 0, 0, 0, 0, 0, 0, g_strFontName)
Call SelectObject(lngwParam, lFont)
End If
'Create a Solid Brush using that Color
tLB.lbColor = g_BackColor
'Return the Handle to the Brush to Paint the MsgBx
MsgBoxCallBack = CreateBrushIndirect(tLB)
Exit Function
Case WM_DESTROY
'Remove the MsgBx Subclassing
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
Exit Function
End Select
MsgBoxCallBack = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal, NewProc As Long
Dim strClassName As String, lngBuffer As Long
If idHook < HC_ACTION Then
NewProc = CallNextHookEx(lngHook2, idHook, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If idHook = HCBT_ACTIVATE Then 'a window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
'if it is our MsgBx then call the Flashing & scrolling procs
If Left$(strClassName, RetVal) = "#32770" Then
'store this param in a Public var for later use
lngHwnd2 = wParam
If g_blnFlashTitle Then
Call FlashWindow(wParam)
End If
If g_blnScrollText Then
Call StartScrollingTimer
End If
End If
End If
CallNextHookEx lngHook2, idHook, wParam, lParam
End Function4-Yet, in another Standard Module (to run supporting routines)
Code:
'Option Explicit
Sub StartCountDown(lngTimeOut As Long)
lngCounter = 6
g_StrPrompt = g_StrPrompt + Space(5)
g_lngTimeOut = lngTimeOut
lngTimerID = SetTimer(0, 0, 1000, AddressOf CountDown)
End Sub
Function FormatTime(lngSec As Long) As String
Select Case lngSec
Case 0 To 59
FormatTime = "00:00:" & Format(lngSec, "00")
Case 60 To 3599
FormatTime = "00:" & Format(lngSec \ 60, "00") & ":" _
& Format((lngSec Mod 60), "00")
Case Is >= 3600
FormatTime = Format(lngSec \ 3600, "00") & ":" _
& Format((lngSec Mod 3600) \ 60, "00") _
& ":" & Format((lngSec Mod 60), "00")
End Select
End Function
Sub CountDown()
SetWindowText lngHwnd2, " * " & FormatTime(g_lngTimeOut) _
& " " & String(lngCounter, "<") ' & "Time remaining!"
If lngCounter = 0 Then lngCounter = 6
g_lngTimeOut = g_lngTimeOut - 1
If g_lngTimeOut < 0 Then
SetForegroundWindow lngHwnd2
keybd_event &HD, 0, 0, 0
keybd_event &HD, 0, KEYEVENTF_KEYUP, 0
End If
lngCounter = lngCounter - 1
End Sub
Sub PlaySoundNow(strSoundFile As String)
strSoundFile = strSoundFile
sndPlaySound strSoundFile, SND_LOOP + SND_ASYNC + SND_NODEFAULT '9
End Sub
Sub SpeakText(strSpeachText As String)
Dim objSpeech As Object
On Error Resume Next
'set this prop only if XL version has Speech object
Set objSpeech = CallByName(Application, "Speech", VbGet)
Set objSpeech = Nothing
If Err <> 0 Then Exit Sub
Application.Speech.Speak _
strSpeachText, True
End Sub
Sub InstallHooks()
Dim lngAppHwnd, lngAppInstance, lngPrcssID As Long
'****************************************************************
'Application.Hwnd & Application.Hinstance properties only
'work for XL2002 or later !
'so let's get these via the win API so it works for all versions.
'****************************************************************
'get XL wnd handle
lngAppHwnd = FindWindow("XLMAIN", Application.Caption)
'get XL instance
lngAppInstance = GetWindowLong(lngAppHwnd, GWL_HINSTANCE)
'get XL prcess ID
lngPrcssID = GetWindowThreadProcessId(lngAppHwnd, 0)
'Hook the XL app now passing the above parameters
lngHook = SetWindowsHookEx _
(WH_CALLWNDPROC, AddressOf HookWindows, lngAppInstance _
, lngPrcssID)
lngHook2 = SetWindowsHookEx _
(WH_CBT, AddressOf HookProc, lngAppInstance, _
lngPrcssID)
End Sub
Sub KillTimers()
killtimerAPI 0, lngTimerID
killtimerAPI 0, lngTimerID2
End Sub
Sub StopSound()
sndPlaySound strSoundFile, 9
End Sub
Sub Un_InstallHooks()
UnhookWindowsHookEx lngHook
UnhookWindowsHookEx lngHook2
End Sub
Sub PositionMsgBox(hwnd As Long)
Dim rectDlgPos As RECT
Dim NewLeft, NewTop As Long
Dim lngScreenWidth, lngScreenHeight, lngMsgBxWidth, lngMsgBxHeight
GetWindowRect hwnd, rectDlgPos
lngScreenWidth = GetSystemMetrics(SM_CXSCREEN)
lngScreenHeight = GetSystemMetrics(SM_CYSCREEN)
lngMsgBxWidth = rectDlgPos.Right - rectDlgPos.Left
lngMsgBxHeight = rectDlgPos.Bottom - rectDlgPos.Top
Select Case g_ScreenPos
Case Is = ScreenPosition.Atthetop
NewLeft = (lngScreenWidth - lngMsgBxWidth) / 2: NewTop = O
Case Is = ScreenPosition.ToTheLeft
NewLeft = 0: NewTop = (lngScreenHeight - lngMsgBxHeight) / 2
Case Is = ScreenPosition.AtTheBottom
NewLeft = (lngScreenWidth - lngMsgBxWidth) / 2: _
NewTop = (lngScreenHeight - (lngMsgBxHeight))
Case Is = ScreenPosition.ToTheRight
NewLeft = (lngScreenWidth - lngMsgBxWidth): _
NewTop = (lngScreenHeight - lngMsgBxHeight) / 2
Case Is = ScreenPosition.TopLeft
NewLeft = 0: NewTop = 0
Case Is = ScreenPosition.TopRight
NewLeft = (lngScreenWidth - lngMsgBxWidth): NewTop = 0
Case Is = ScreenPosition.BottomLeft
NewLeft = 0: NewTop = (lngScreenHeight - lngMsgBxHeight)
Case Is = ScreenPosition.BottomRight
NewLeft = (lngScreenWidth - lngMsgBxWidth): NewTop = _
(lngScreenHeight - lngMsgBxHeight)
Case Is = ScreenPosition.Centered
NewLeft = (lngScreenWidth - lngMsgBxWidth) / 2: _
NewTop = (lngScreenHeight - lngMsgBxHeight) / 2
End Select
SetWindowPos hwnd, 0, NewLeft _
, NewTop, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
End Sub
Public Sub Animate_Window(hwnd As Long)
AnimateWindow hwnd, 1000, g_Animation
End Sub
Sub ScrollTextProc()
On Error Resume Next
lngScrollCounter = lngScrollCounter + 1
If lngScrollCounter Mod Len(g_StrPrompt) = 0 _
Then lngScrollCounter = 1: lngCycle = lngCycle + 1
If lngCycle Mod 2 <> 0 Then
SetWindowText lngStaticTextHwnd, Space(1 * (Len(g_StrPrompt) - lngScrollCounter)) _
& Left(g_StrPrompt, lngScrollCounter) '
Else
SetWindowText lngStaticTextHwnd, Mid(g_StrPrompt, lngScrollCounter, Len(g_StrPrompt) - 1)
End If
End Sub
Sub StartScrollingTimer()
Dim lngTimerInterval As Long
'set the timer speed in milli_secs
If g_Speed = high Then lngTimerInterval = 25
If g_Speed = Medium Then lngTimerInterval = 50
If g_Speed = low Then lngTimerInterval = 80
'reset counters
lngScrollCounter = 0
lngCycle = 0
'get the MsgBx text window needed for the timer callback proc
lngStaticTextHwnd = FindWindowEx(lngHwnd2, 0, "STATIC", vbNullString)
'set the second timer to update the MsgBx text while it is displayed
lngTimerID2 = SetTimer(0, 0, lngTimerInterval, AddressOf ScrollTextProc)
End Sub
Public Sub FlashWindow(hwnd As Long)
Dim tflashinfo As FLASHWINFO
'fill the flash struct
With tflashinfo
.cbSize = Len(tflashinfo)
.dwFlags = FLASHW_TIMER + FLASHW_CAPTION
.dwTimeout = 0
.hwnd = hwnd
.uCount = 0
End With
'start flashing the MsgBx now
FlashWindowEx tflashinfo
End Sub5-In a last Standard Module for using the Class :
Code:
Sub Test()
Dim MyMsgBox As clss_CustomMsgbx
Set MyMsgBox = New clss_CustomMsgbx
With MyMsgBox
.BackColor = Cyan
.FontName = "Comic Sans MS"
.FontBold = True
.FontColor = Red
.FontSize = 24
.FontItalic = False
.Title = "Custom Msgbox..."
.Buttons = vbOKOnly
.Prompt = "Hello there :)!... How are you today ?..."
' **change this Sound file PATH as required **
.PlaySound "C:\Program Files\Windows NT\Pinball\sound24.wav"
.TimeOut = 99 ' seconds
.Speak "Hello Mr" & Application.UserName
.ScrollText Medium
.FlashTitle = True
.ScreenPos = Centered
.Animation = Fade
.Show
End With
End SubOne nice missing feature is to be able to make the MsgBox Modeless.Unfortunately, I just can't seem to make it work...maybe someday or someone will find the solution
I have only tried the code in XL2002 so I am not sure if it will work for other versions.
Regards.
