Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
Hi all,
Following a question I saw the other day, where it was asked if we could change the color of the Buttons in the standard vba MsgBox, I decided to give it a shot since I have never seen any code anywhere that addresses the issue. I have seen code before that sets the background color but never the Buttons colors.
As I got my hands dirty writing this stuff, I decided to take it a couple of steps further and offer the possibility of adding a background image to the MsgBox or making it transparent.
Workbook Demo:
Formatted_MsgBox.xlsm
The code is very easy and intuitive to use. No abstract Classes needed. The entire API stuff is located in a separate Standard Module hence, the user is insulated from the complexities of the code.
When trying to implement the code, each MsgBox Item (ie:= Prompt Text and\or Buttons) is addressed by its name (for easy use) in order to set the desired colors.
So for example: To set the OK button backround and Text colors, you simply do something along these lines:
Where ColoredMsgBx is a UDT that holds all the items information.
1- API code in a Standard Module:
2- CODE USAGE EXAMPLES:
Tested on x64bit (win10) only but, hopefully, it should work in x32bit as well.
Any feedback provided on bugs and any suggestions are welcome.
Regards.
Following a question I saw the other day, where it was asked if we could change the color of the Buttons in the standard vba MsgBox, I decided to give it a shot since I have never seen any code anywhere that addresses the issue. I have seen code before that sets the background color but never the Buttons colors.
As I got my hands dirty writing this stuff, I decided to take it a couple of steps further and offer the possibility of adding a background image to the MsgBox or making it transparent.
Workbook Demo:
Formatted_MsgBox.xlsm
The code is very easy and intuitive to use. No abstract Classes needed. The entire API stuff is located in a separate Standard Module hence, the user is insulated from the complexities of the code.
When trying to implement the code, each MsgBox Item (ie:= Prompt Text and\or Buttons) is addressed by its name (for easy use) in order to set the desired colors.
So for example: To set the OK button backround and Text colors, you simply do something along these lines:
Dim tMsgBox As ColoredMsgBx
With tMsgBox
.OK_BTN.BACKCOLOR = vbGreen
.OK_BTN.TEXTCOLOR = vbRed
End With
Where ColoredMsgBx is a UDT that holds all the items information.
1- API code in a Standard Module:
VBA Code:
Option Explicit
Public Type ITEM_ATTRIBUTES
BACKCOLOR As Variant
TEXTCOLOR As Variant
End Type
Public Type ColoredMsgBx
PICTURE As StdPicture
HIDE_TEXT_PROMPT As Boolean
TRANSPARENT As Boolean '
BACKCOLOR As Variant
PROMPT As ITEM_ATTRIBUTES
OK_BTN As ITEM_ATTRIBUTES
CANCEL_BTN As ITEM_ATTRIBUTES
YES_BTN As ITEM_ATTRIBUTES
NO_BTN As ITEM_ATTRIBUTES
ABORT_BTN As ITEM_ATTRIBUTES
RETRY_BTN As ITEM_ATTRIBUTES
IGNORE_BTN As ITEM_ATTRIBUTES
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PAINTSTRUCT
#If Win64 Then
hdc As LongLong
#Else
hdc As Long
#End If
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(0 To 31) As Byte
End Type
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
#If Win64 Then
lbHatch As LongLong
#Else
lbHatch As Long
#End If
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongLong
Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#End If
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
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 Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hKBhook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
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 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex 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 SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetDlgCtrlID Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) 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 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 DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr, Optional ByVal dwRefData As LongPtr) As LongPtr
Private Declare PtrSafe Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As LongPtr, ByVal pfnSubclass As LongPtr, ByVal uIdSubclass As LongPtr) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function DrawFocusRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function OleTranslateColor Lib "oleAut32.dll" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function ColorAdjustLuma Lib "shlwapi.dll" (ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
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 LineTo Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private hCBTHook As LongPtr, lPrvWndProc As LongPtr
Private hBrushMsgbox As LongPtr, hBrushPrompt As LongPtr
Private hBrush1 As LongPtr, hBrush2 As LongPtr, hBrush3 As LongPtr
Private hLBrush1 As LongPtr, hLBrush2 As LongPtr, hLBrush3 As LongPtr
Private lStartTime As LongPtr
#Else
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA " (ByVal hwnd As Long , ByVal nIndex As Long, ByVal dwNewLong As Long ) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
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 Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hKBhook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hKBhook As Long) As Long
Private 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
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wFlag As Long) 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 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 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 BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Private Declare Function GetDlgItemText Lib "user32" Alias "GetDlgItemTextA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgCtrlID Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor 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 CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) 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 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 DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDc As Long, lpRect As RECT) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function OleTranslateColor Lib "oleAut32.dll" (ByVal clr As OLE_COLOR, ByVal palet As Long, col As Long) As Long
Private Declare Function ColorAdjustLuma Lib "shlwapi.dll" (ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) 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 LineTo Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private hCBTHook As Long, lPrvWndProc As Long
Private hBrushMsgbox As Long, hBrushPrompt As Long
Private hBrush1 As Long, hBrush2 As Long, hBrush3 As Long
Private hLBrush1 As Long, hLBrush2 As Long, hLBrush3 As Long
Private lStartTime As Long
#End If
Private tMsgboxStructure As ColoredMsgBx
Private oStdPic As StdPicture
Private bMsgShown As Boolean
'_____________________________________________ PUBLIC ROUTINE __________________________________________________
Public Sub ApplyMsgBoxFormatting(ByRef tMsgBx As ColoredMsgBx)
If Not tMsgBx.PICTURE Is Nothing Then
Set oStdPic = tMsgBx.PICTURE
End If
tMsgboxStructure = tMsgBx
bMsgShown = False
lStartTime = GetTickCount
SetTimer Application.hwnd, 0, 1000, AddressOf TimerProc
Call HookMsgBox
End Sub
'_____________________________________________ PRIVATE ROUTINES __________________________________________________
Private Sub HookMsgBox(Optional ByVal bHook As Boolean = True)
Const WH_CBT = 5
If bHook Then
If hCBTHook = 0 Then
hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
End If
Else
Call UnhookWindowsHookEx(hCBTHook)
hCBTHook = 0
End If
End Sub
#If Win64 Then
Private Sub TimerProc( _
ByVal hwnd As LongLong, _
ByVal message As Long, _
ByVal idTimer As Long, _
ByVal dwTime As Long _
)
#Else
Private Sub TimerProc( _
ByVal hwnd As Long, _
ByVal message As Long, _
ByVal idTimer As Long, _
ByVal dwTime As Long _
)
#End If
If (dwTime - lStartTime) / 1000 > 1 Then
If bMsgShown = False Then
Call KillTimer(Application.hwnd, 0)
Call HookMsgBox(False)
Debug.Print "No MsgBox shown so far. So, clear hook and quietly exit."
Exit Sub
End If
End If
End Sub
#If Win64 Then
Private Function HookProc( _
ByVal idHook As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong _
) As LongLong
Dim hButtonsAr() As LongLong
#Else
Private Function HookProc( _
ByVal idHook As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
Dim hButtonsAr() As Long
#End If
Const HC_ACTION = 0
Const HCBT_ACTIVATE = 5
Const HCBT_DESTROYWND = 4
Const COLOR_WINDOW = 5
Const COLOR_BTNFACE = 15
Dim tEmptyMsgboxStructure As ColoredMsgBx
Dim tLGB As LOGBRUSH
Dim i As Long, lButtonsIDsSum As Long
Dim sBuffer As String, lRet As Long
Dim lWindColor As Long, lBtnColor As Long
If idHook < HC_ACTION Then
HookProc = CallNextHookEx(hCBTHook, idHook, wParam, lParam)
Exit Function
End If
If idHook = HCBT_ACTIVATE Then
sBuffer = VBA.Space(256)
lRet = GetClassName(wParam, sBuffer, 256)
If VBA.Left(sBuffer, lRet) = "#32770" Then
bMsgShown = True
Call KillTimer(Application.hwnd, 0)
hButtonsAr = GetButtonsHwnds(wParam)
For i = LBound(hButtonsAr) To UBound(hButtonsAr)
lButtonsIDsSum = lButtonsIDsSum + GetDlgCtrlID(hButtonsAr(i))
Next i
Call TranslateColor(GetSysColor(COLOR_WINDOW), 0, lWindColor)
Call TranslateColor(GetSysColor(COLOR_BTNFACE), 0, lBtnColor)
With tMsgboxStructure
Select Case lButtonsIDsSum
Case &H1 'vbOkOnly
hBrush1 = CreateSolidBrush(IIf(.OK_BTN.BACKCOLOR = Empty, lBtnColor, .OK_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.OK_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.OK_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 1), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 1), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 1), "TextColor", .OK_BTN.TEXTCOLOR
Case &H3 'vbOkCancel
hBrush1 = CreateSolidBrush(IIf(.OK_BTN.BACKCOLOR = Empty, lBtnColor, .OK_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.OK_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.OK_BTN.BACKCOLOR, 40)))
hBrush2 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, .CANCEL_BTN.BACKCOLOR))
hLBrush2 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.CANCEL_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 1), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 1), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 1), "TextColor", .OK_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 2), "BackColor", hBrush2
SetProp GetDlgItem(wParam, 2), "LBackColor", hLBrush2
SetProp GetDlgItem(wParam, 2), "TextColor", .CANCEL_BTN.TEXTCOLOR
Case &H6 'vbRetryCancel
hBrush1 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, .CANCEL_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.CANCEL_BTN.BACKCOLOR, 40)))
hBrush2 = CreateSolidBrush(IIf(.RETRY_BTN.BACKCOLOR = Empty, lBtnColor, .RETRY_BTN.BACKCOLOR))
hLBrush2 = CreateSolidBrush(IIf(.RETRY_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.RETRY_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 2), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 2), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 2), "TextColor", .CANCEL_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 4), "BackColor", hBrush2
SetProp GetDlgItem(wParam, 4), "LBackColor", hLBrush2
SetProp GetDlgItem(wParam, 4), "TextColor", .RETRY_BTN.TEXTCOLOR
Case &HC 'vbAbortRetryIgnore
hBrush1 = CreateSolidBrush(IIf(.ABORT_BTN.BACKCOLOR = Empty, lBtnColor, .ABORT_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.ABORT_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.ABORT_BTN.BACKCOLOR, 40)))
hBrush2 = CreateSolidBrush(IIf(.RETRY_BTN.BACKCOLOR = Empty, lBtnColor, .RETRY_BTN.BACKCOLOR))
hLBrush2 = CreateSolidBrush(IIf(.RETRY_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.RETRY_BTN.BACKCOLOR, 40)))
hBrush3 = CreateSolidBrush(IIf(.IGNORE_BTN.BACKCOLOR = Empty, lBtnColor, .IGNORE_BTN.BACKCOLOR))
hLBrush3 = CreateSolidBrush(IIf(.IGNORE_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.IGNORE_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 3), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 3), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 3), "TextColor", .ABORT_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 4), "BackColor", hBrush2
SetProp GetDlgItem(wParam, 4), "LBackColor", hLBrush2
SetProp GetDlgItem(wParam, 4), "TextColor", .RETRY_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 5), "BackColor", hBrush3
SetProp GetDlgItem(wParam, 5), "LBackColor", hLBrush3
SetProp GetDlgItem(wParam, 5), "TextColor", .IGNORE_BTN.TEXTCOLOR
Case &HD 'vbYesNo
hBrush1 = CreateSolidBrush(IIf(.YES_BTN.BACKCOLOR = Empty, lBtnColor, .YES_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.YES_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.YES_BTN.BACKCOLOR, 40)))
hBrush2 = CreateSolidBrush(IIf(.NO_BTN.BACKCOLOR = Empty, lBtnColor, .NO_BTN.BACKCOLOR))
hLBrush2 = CreateSolidBrush(IIf(.NO_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.NO_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 6), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 6), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 6), "TextColor", .YES_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 7), "BackColor", hBrush2
SetProp GetDlgItem(wParam, 7), "LBackColor", hLBrush2
SetProp GetDlgItem(wParam, 7), "TextColor", .NO_BTN.TEXTCOLOR
Case &HF 'vbYesNoCancel
hBrush1 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, .CANCEL_BTN.BACKCOLOR))
hLBrush1 = CreateSolidBrush(IIf(.CANCEL_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.CANCEL_BTN.BACKCOLOR, 40)))
hBrush2 = CreateSolidBrush(IIf(.YES_BTN.BACKCOLOR = Empty, lBtnColor, .YES_BTN.BACKCOLOR))
hLBrush2 = CreateSolidBrush(IIf(.YES_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.YES_BTN.BACKCOLOR, 40)))
hBrush3 = CreateSolidBrush(IIf(.NO_BTN.BACKCOLOR = Empty, lBtnColor, .NO_BTN.BACKCOLOR))
hLBrush3 = CreateSolidBrush(IIf(.NO_BTN.BACKCOLOR = Empty, lBtnColor, TintAndShade(.NO_BTN.BACKCOLOR, 40)))
SetProp GetDlgItem(wParam, 2), "BackColor", hBrush1
SetProp GetDlgItem(wParam, 2), "LBackColor", hLBrush1
SetProp GetDlgItem(wParam, 2), "TextColor", .CANCEL_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 6), "BackColor", hBrush2
SetProp GetDlgItem(wParam, 6), "LBackColor", hLBrush2
SetProp GetDlgItem(wParam, 6), "TextColor", .YES_BTN.TEXTCOLOR
SetProp GetDlgItem(wParam, 7), "BackColor", hBrush3
SetProp GetDlgItem(wParam, 7), "LBackColor", hLBrush3
SetProp GetDlgItem(wParam, 7), "TextColor", .NO_BTN.TEXTCOLOR
End Select
For i = LBound(hButtonsAr) To UBound(hButtonsAr)
Call SetWindowSubclass(hButtonsAr(i), WinProcAddr, GetProp(hButtonsAr(i), "BackColor"), GetProp(hButtonsAr(i), "TextColor"))
Next i
hBrushMsgbox = CreateSolidBrush(IIf(.BACKCOLOR = Empty, lWindColor, .BACKCOLOR))
SetProp wParam, "BackColor", hBrushMsgbox
Call GetObjectAPI(hBrushMsgbox, LenB(tLGB), tLGB)
hBrushPrompt = CreateSolidBrush(IIf(.PROMPT.BACKCOLOR = Empty, tLGB.lbColor, .PROMPT.BACKCOLOR))
SetProp GetDlgItem(wParam, &HFFFF&), "BackColor", hBrushPrompt
SetProp GetDlgItem(wParam, &HFFFF&), "TextColor", CLng(.PROMPT.TEXTCOLOR)
End With
Call SetWindowSubclass(wParam, WinProcAddr, GetProp(wParam, "BackColor"), ByVal 0)
Call SubclassMsgBox(wParam)
End If
End If
If idHook = HCBT_DESTROYWND Then
sBuffer = VBA.Space(256)
lRet = GetClassName(wParam, sBuffer, 256)
If VBA.Left(sBuffer, lRet) = "#32770" Then
Call DeleteObject(hBrush1)
Call DeleteObject(hBrush2)
Call DeleteObject(hBrush3)
Call DeleteObject(hLBrush1)
Call DeleteObject(hLBrush2)
Call DeleteObject(hLBrush3)
Call DeleteObject(hBrushMsgbox)
Call DeleteObject(hBrushPrompt)
tMsgboxStructure = tEmptyMsgboxStructure
Set oStdPic = Nothing
bMsgShown = False
Call HookMsgBox(False)
End If
End If
HookProc = CallNextHookEx(hCBTHook, idHook, ByVal wParam, ByVal lParam)
End Function
#If Win64 Then
Private Sub SubclassMsgBox(ByVal hwnd As LongLong, Optional ByVal bHook As Boolean = True)
#Else
Private Sub SubclassMsgBox(ByVal hwnd As Long, Optional ByVal bHook As Boolean = True)
#End If
Const GWL_WNDPROC = (-4)
If bHook And lPrvWndProc = 0 Then
lPrvWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
Else
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrvWndProc)
lPrvWndProc = 0
End If
End Sub
#If Win64 Then
Private Function WinProc( _
ByVal hwnd As LongLong, _
ByVal Msg As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong _
) As LongLong
#Else
Private Function WinProc( _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
#End If
Const WM_CTLCOLORDLG = &H136
Const WM_CTLCOLORSTATIC = &H138
Const WM_DESTROY = &H2
Const TRANSPARENT = 1
Select Case Msg
Case Is = WM_CTLCOLORDLG
WinProc = GetProp(hwnd, "BackColor")
Exit Function
Case Is = WM_CTLCOLORSTATIC
Call SetBkMode(wParam, TRANSPARENT)
If GetDlgCtrlID(lParam) = &HFFFF& Then
Call SetTextColor(wParam, CLng(GetProp(lParam, "TextColor")))
WinProc = GetProp(lParam, "BackColor")
Else
WinProc = GetProp(hwnd, "BackColor")
End If
Exit Function
Case Is = WM_DESTROY
Call SubclassMsgBox(hwnd, False)
End Select
WinProc = CallWindowProc(lPrvWndProc, hwnd, Msg, wParam, ByVal lParam)
End Function
#If Win64 Then
Private Function DefWinProc( _
ByVal hwnd As LongLong, _
ByVal wMsg As Long, _
ByVal wParam As LongLong, _
ByVal lParam As LongLong, _
ByVal uIdSubclass As LongLong, _
ByVal This As LongLong _
) As LongLong
Dim Ptr As LongLong, hBrush As LongLong
Dim hFont As LongLong, hPrevFont As LongLong
Dim hFrameBrush As LongLong, hHideBrush As LongLong
Dim hMemDc As LongLong
Dim hWinFromPt As LongLong
Dim hPrompt As LongLong, hIcon As LongLong
Dim hPicBmp As LongLong
#Else
Private Function DefWinProc( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long, _
ByVal uIdSubclass As Long, _
ByVal This As Long _
) As Long
Dim hBrush As Long
Dim hFont As Long, hPrevFont As Long
Dim hFrameBrush As Long, hHideBrush As Long
Dim hMemDc As Long
Dim hWinFromPt As Long
Dim hPrompt As Long, hIcon As Long
Dim hPicBmp As Long
#End If
Const WM_PAINT = &HF
Const WM_DESTROY = &H2
Const WM_GETFONT = &H31
Const DT_CENTER = &H1
Const DT_VCENTER = &H4
Const SRCCOPY = &HCC0020
Const TRANSPARENT = 1
Const LWA_COLORKEY = &H1
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000
Const IMAGE_BITMAP = 0
Const LR_LOADFROMFILE = &H10
Dim tPS As PAINTSTRUCT
Dim tWinRect As RECT, tBrushRect As RECT, tFocusRect As RECT
Dim tCurPos As POINTAPI
Dim sBuffer As String, lRet As Long
On Error Resume Next
hPrompt = GetDlgItem(GetParent(hwnd), &HFFFF&)
hIcon = GetDlgItem(GetParent(hwnd), &H14)
If tMsgboxStructure.HIDE_TEXT_PROMPT Then
Call ShowWindow(hPrompt, 0)
Call ShowWindow(hIcon, 0)
End If
Select Case wMsg
Case WM_PAINT
Call BeginPaint(hwnd, tPS)
sBuffer = VBA.Space(256)
lRet = GetClassName(hwnd, sBuffer, 256)
Call GetClientRect(hwnd, tWinRect)
If VBA.Left(sBuffer, lRet) = "#32770" Then
If tMsgboxStructure.TRANSPARENT Then
hHideBrush = CreateSolidBrush(RGB(1, 101, 255))
Call FillRect(tPS.hdc, tWinRect, hHideBrush)
Call DeleteObject(hHideBrush)
Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(hwnd, RGB(1, 101, 255), 0, LWA_COLORKEY)
End If
If Not (oStdPic Is Nothing) And tMsgboxStructure.TRANSPARENT = False Then
With tWinRect
hMemDc = CreateCompatibleDC(tPS.hdc)
Const LR_COPYRETURNORG = &H4
hPicBmp = CopyImage(oStdPic.handle, IMAGE_BITMAP, .Right - .Left, .Bottom - .Top, LR_COPYRETURNORG)
Call SelectObject(hMemDc, hPicBmp)
Call BitBlt(tPS.hdc, 0, 0, .Right - .Left + 150, .Bottom - .Top, hMemDc, 0, 0, SRCCOPY)
Call DeleteDC(hMemDc)
Call DeleteObject(hPicBmp)
Exit Function
End With
End If
End If
If VBA.Left(sBuffer, lRet) = "Button" Then
Call GetClientRect(hwnd, tWinRect)
With tWinRect
Call SetRect(tFocusRect, 3, 3, .Right - 4, .Bottom - 4)
Call GetCursorPos(tCurPos)
#If Win64 Then
Call CopyMemory(Ptr, tCurPos, LenB(tCurPos))
hWinFromPt = WindowFromPoint(Ptr)
#Else
hWinFromPt = WindowFromPoint(tCurPos.X, tCurPos.Y)
#End If
If hWinFromPt <> hwnd Then
hBrush = GetProp(hwnd, "BackColor")
Call FillRect(tPS.hdc, tWinRect, hBrush)
Else
hBrush = GetProp(hwnd, "LBackColor")
Call FillRect(tPS.hdc, tWinRect, hBrush)
End If
Call SetBkMode(tPS.hdc, TRANSPARENT)
hFont = SendMessage(hwnd, WM_GETFONT, 0, 0)
hPrevFont = SelectObject(tPS.hdc, hFont)
Call SetRect(tWinRect, 0, .Bottom / 6, .Right, .Bottom)
sBuffer = Space(256)
lRet = GetDlgItemText(GetParent(hwnd), GetDlgCtrlID(hwnd), sBuffer, 256)
Call SetTextColor(tPS.hdc, CLng(GetProp(hwnd, "TextColor")))
Call DrawText(tPS.hdc, Left(sBuffer, lRet), lRet, tWinRect, DT_CENTER + DT_VCENTER)
Call SelectObject(tPS.hdc, hPrevFont)
Call SetRect(tWinRect, 0, 0, .Right, .Bottom)
hFrameBrush = CreateSolidBrush(0)
Call FrameRect(tPS.hdc, tWinRect, hFrameBrush)
Call DeleteObject(hFrameBrush)
If GetFocus = hwnd Then
Call DrawFocusRect(tPS.hdc, tFocusRect)
hMemDc = DrawActiveDC(hwnd, tMsgboxStructure)
Call BitBlt(tPS.hdc, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, 0, 0, SRCCOPY)
Call DeleteDC(hMemDc)
End If
End With
Call EndPaint(hwnd, tPS)
End If
Case WM_DESTROY
Call RemoveWindowSubclass(hwnd, WinProcAddr, ByVal GetDlgCtrlID(hwnd))
End Select
DefWinProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)
End Function
#If Win64 Then
Private Function DrawActiveDC(ByVal hwnd As LongLong, tMsgBx As ColoredMsgBx) As LongLong
Dim hMemDc As LongLong, hSrcDC As LongLong
Dim hBmp As LongLong, hPrvBmp As LongLong
Dim hPen As LongLong, hPrevPen As LongLong
#Else
Private Function DrawActiveDC(ByVal hwnd As Long, tMsgBx As ColoredMsgBx) As Long
Dim hMemDc As Long, hSrcDC As Long
Dim hBmp As Long, hPrvBmp As Long
Dim hPen As Long, hPrevPen As Long
#End If
Const PS_SOLID = 1
Const SRCCOPY = &HCC0020
Const COLOR_3DDKSHADOW = 21
Dim tRect As RECT
Dim lRealCol As Long
Call GetClientRect(hwnd, tRect)
hSrcDC = GetDC(hwnd)
With tRect
hMemDc = CreateCompatibleDC(hSrcDC)
hBmp = CreateCompatibleBitmap(hSrcDC, .Right - .Left, .Bottom - .Top)
hPrvBmp = SelectObject(hMemDc, hBmp)
Call BitBlt(hMemDc, 0, 0, .Right - .Left, .Bottom - .Top, hSrcDC, 0, 0, SRCCOPY)
Call TranslateColor(GetSysColor(COLOR_3DDKSHADOW), 0, lRealCol)
hPen = CreatePen(PS_SOLID, 5, IIf(GetSysColor(COLOR_3DDKSHADOW) = 0, 0, lRealCol))
hPrevPen = SelectObject(hMemDc, hPen)
Call MoveToEx(hMemDc, .Right, .Top, ByVal 0)
Call LineTo(hMemDc, .Right, .Bottom)
Call LineTo(hMemDc, .Left, .Bottom)
End With
DrawActiveDC = hMemDc
Call ReleaseDC(hwnd, hSrcDC)
Call SelectObject(hMemDc, hPrevPen)
Call DeleteObject(hPen)
Call DeleteObject(hBmp)
End Function
#If Win64 Then
Private Function GetButtonsHwnds(ByVal hwnd As LongLong) As LongLong()
Dim ar() As LongLong, hwndChild As LongLong
#Else
Private Function GetButtonsHwnds(ByVal hwnd As Long) As Long()
Dim ar() As Long, hwndChild As Long
#End If
Const GW_CHILD = 5
Const GW_HWNDNEXT = 2
Dim sBuffer As String, lRet As Long, i As Long
hwndChild = GetWindow(hwnd, GW_CHILD)
Do While hwndChild
sBuffer = VBA.Space(256)
lRet = GetClassName(hwndChild, sBuffer, 256)
If VBA.Left(sBuffer, lRet) = "Button" Then
ReDim Preserve ar(i)
ar(i) = hwndChild
i = i + 1
End If
hwndChild = GetWindow(hwndChild, GW_HWNDNEXT) 'Continue Enumeration
Loop
GetButtonsHwnds = ar
End Function
Private Function TintAndShade(ByVal ColRef As Long, Optional ByVal Luminance As Long = 0) As Long
'(Luminance must be between -100 and +100)
Call TranslateColor(ColRef, 0, ColRef)
TintAndShade = ColorAdjustLuma(ColRef, Luminance * 10, True)
End Function
#If Win64 Then
Private Function WinProcAddr() As LongLong
WinProcAddr = VBA.CLngLng(AddressOf DefWinProc)
#Else
Private Function WinProcAddr() As Long
WinProcAddr = VBA.CLng(AddressOf DefWinProc)
#End If
End Function2- CODE USAGE EXAMPLES:
VBA Code:
Option Explicit
Sub Test_Transparent()
Dim tMsgBox As ColoredMsgBx
With tMsgBox
.TRANSPARENT = True
.HIDE_TEXT_PROMPT = True
.ABORT_BTN.BACKCOLOR = vbGreen
.IGNORE_BTN.BACKCOLOR = vbCyan
.IGNORE_BTN.TEXTCOLOR = vbRed
.RETRY_BTN.TEXTCOLOR = vbBlue
.RETRY_BTN.BACKCOLOR = vbMagenta
End With
Call ApplyMsgBoxFormatting(tMsgBox)
MsgBox "", vbAbortRetryIgnore, "This is a transparent standard MsgBox demo."
End Sub
Sub Test_Picture()
Dim tMsgBox As ColoredMsgBx
With tMsgBox
.HIDE_TEXT_PROMPT = True
Set .PICTURE = Sheet1.Image1.PICTURE '<= You can also use such as LoadPicture("C:\Users\hp\MyPic.bmp")
.OK_BTN.BACKCOLOR = vbMagenta
.OK_BTN.TEXTCOLOR = vbYellow
End With
Call ApplyMsgBoxFormatting(tMsgBox)
MsgBox String(10, vbNewLine), vbOKOnly, "Standard MsgBox with a background image."
End Sub
Sub Test_MultiColor()
Dim tMsgBox As ColoredMsgBx
With tMsgBox
.BACKCOLOR = &HCCFFFF
.PROMPT.TEXTCOLOR = vbRed
.OK_BTN.BACKCOLOR = &HB4E0C6
.OK_BTN.TEXTCOLOR = &H1262D8
.CANCEL_BTN.BACKCOLOR = &HADCBF8
.CANCEL_BTN.TEXTCOLOR = vbBlue
End With
Call ApplyMsgBoxFormatting(tMsgBox)
MsgBox "This is a Multi-Color standard MsgBox demo.", vbInformation + vbOKCancel
End SubTested on x64bit (win10) only but, hopefully, it should work in x32bit as well.
Any feedback provided on bugs and any suggestions are welcome.
Regards.
)! Beside multi-color MsgBox, can you make multi-color InputBox?
