Formatting the Data Validation Message Box

Y

ybot

New Member
Joined
Dec 12, 2007
Messages
8
I used the Data Validation tool to show a message when a cell is clicked. Is there any way to format the message that appears (i.e. font, color, etc)?

Thanks for your help!

-Toby
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Don't think so. Only solution I could suggest would be a VBA Worksheet Change event to perform the validation and a custom UserForm could be designed how you wish to display any warning. Bit OTT maybe.

Dom
 
Upvote 0
I believe a Data Validation message (as are comments) are really Windows ToolTips. These can be changed in your Windows Properties. In 2003, RightClick the Desktop and Choose Properties>Appearance>Advanced>Item =ToolTip
Format Font and Background Color. Note this will change ALL tooltips in any Windows Application!!
lenze
 
Upvote 0
lenze said:
I believe a Data Validation message (as are comments) are really Windows ToolTips. These can be changed in your Windows Properties. In 2003, RightClick the Desktop and Choose Properties>Appearance>Advanced>Item =ToolTip
Format Font and Background Color. Note this will change ALL tooltips in any Windows Application!!
lenze
Click to expand...

And will only work if you open the workbook on your PC.

Dom
 
Upvote 0
Hi.

As it turns out, the little Data validation input message box has a Class name of EXCELA. I found out using WindowSpy . So i thought maybe I could use some API functions and the Selection_Change event in order to format its background color and text . and guess what it worked ! well at least in excel 2003 where i tested it.

Here is a WORKBOOK DEMO.

I have tried commenting the code for easier reading.


This code goes in the worksheet module :

Code: 
Option Explicit
 
Private WithEvents wb As Workbook
 
Private Sub wb_BeforeClose(Cancel As Boolean)
 
   [COLOR=seagreen][B]'safety measure in case[/B][/COLOR]
    [COLOR=seagreen][B]'the wb is not unhooked before closing.[/B][/COLOR]
    If lPrevWnd Then Call ClearHook
 
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    Dim sTitle As String, sInput As String
 
    On Error Resume Next
 
   [COLOR=seagreen][B]'***********************[/B][/COLOR]
    [B][COLOR=seagreen]'shouldn't be necessary[/COLOR][/B]
    [COLOR=seagreen][B]'but just in case.[/B][/COLOR]
    Set wb = ThisWorkbook
   [COLOR=seagreen][B]'**********************[/B][/COLOR]
 
    sTitle = Target.Validation.InputTitle
    sInput = Target.Validation.InputMessage
 
    If Len(sInput & sTitle) <> 0 Then
        Call StartTimer(ByVal sTitle, ByVal sInput)
    End If
 
    ClearHook
 
End Sub

This code goes in a Standard module :

Code: 
Option Explicit
 
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 LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type
 
Private Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
 
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
Private Declare Function FindWindowEx Lib "user32.dll" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
 
Private Declare Function GetWindowDC 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 SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
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 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 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 CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "user32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
 
Private Declare Function BeginPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function EndPaint Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
 
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
 
Private Declare Function GetClientRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
Private Declare Function GetMessage Lib "user32.dll" _
Alias "GetMessageA" _
(ByRef lpMsg As MSG, _
ByVal hwnd As Long, _
ByVal wMsgFilterMin As Long, _
ByVal wMsgFilterMax As Long) As Long
 
Private Declare Function TranslateMessage Lib "user32.dll" _
(ByRef lpMsg As MSG) As Long
 
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam 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 DrawEdge Lib "user32" _
(ByVal hdc As Long, _
qrc As RECT, _
ByVal edge As Long, _
ByVal grfFlags As Long) As Long
 
Private Declare Function InvalidateRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
 
Private Declare Function SetWindowPos Lib "user32.dll" _
(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
 
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
[COLOR=seagreen][B]'========================================[/B][/COLOR]
'System Constantes.
Private Const GWL_WNDPROC As Long = -4
Private Const WM_PAINT As Long = &HF&
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOACTIVATE As Long = &H10
Private Const DT_WORDBREAK As Long = &H10
 
Private Const BDR_RAISEDOUTER As Long = &H1
Private Const BDR_SUNKENINNER As Long = &H8
Private Const EDGE_BUMP As Long = _
(BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const BF_LEFT As Long = &H1
Private Const BF_RIGHT As Long = &H4
Private Const BF_TOP As Long = &H2
Private Const BF_BOTTOM As Long = &H8
Private Const BF_RECT As Long = _
(BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
[COLOR=seagreen][B]'=====================================[/B][/COLOR]
 
[B][COLOR=seagreen]'User global Constantes.[/COLOR][/B]
[B][COLOR=seagreen]'Change their values as required.[/COLOR][/B]
Private Const TITLE_FONT_HEIGHT = 16
Private Const TITLE_FONT_WIDTH = 6
Private Const TITLE_FONT_BOLD = True
Private Const TITLE_FONT_COLOR = vbRed
Private Const INPUT_FONT_HEIGHT = 14
Private Const INPUT_FONT_WIDTH = 5
Private Const INPUT_FONT_BOLD = False
Private Const INPUT_FONT_COLOR = vbBlue
Private Const INPUT_BCKG_COLOR = vbCyan
 
[COLOR=seagreen][B]'this is the DV input msg box[/B][/COLOR]
[COLOR=seagreen][B]'class name in XL 2003.[/B][/COLOR]
[COLOR=seagreen][B]'not sure about other XL versions.[/B][/COLOR]
Private Const DV_INPUT_MSG_CLASS As String = "EXCELA"
[COLOR=seagreen][B]'====================================[/B][/COLOR]
 
[COLOR=seagreen][B]'Module variables.[/B][/COLOR]
Private tWnRect As RECT
Private tClientRect As RECT
Private bXitLoop As Boolean
Private bFirstCall As Boolean
Private sInputMessage As String
Private sInputTitle As String
Private lDVhwnd As Long
Private lTimerID As Long
Private ldc As Long
[COLOR=seagreen][B]'==============================[/B][/COLOR]
 
[COLOR=seagreen][B]'Global Vars.[/B][/COLOR]
Public lPrevWnd As Long
 
 
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal MSG As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
 
 
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim hBrush As Long
 
 
    On Error Resume Next
 
   [COLOR=seagreen][B]'build the default brush.[/B][/COLOR]
    tLB.lbColor = INPUT_BCKG_COLOR
    hBrush = CreateBrushIndirect(tLB)
 
   [COLOR=seagreen][B]'store the DV dimensions.[/B][/COLOR]
    GetClientRect hwnd, tClientRect
    GetWindowRect hwnd, tWnRect
 
    [COLOR=seagreen][B]'intercept the WM_PAINT Msg.[/B][/COLOR]
    Select Case MSG
 
        Case WM_PAINT
 
            If bFirstCall Then
                SetWindowPos hwnd, 0, 0, 0, _
                tWnRect.Right - tWnRect.Left, _
                (tWnRect.Bottom - tWnRect.Top) + 10, _
                SWP_NOACTIVATE + SWP_NOMOVE
                bFirstCall = False
            End If
 
           [COLOR=seagreen][B]'start the text & bckgrnd formatting.[/B][/COLOR]
            ldc = BeginPaint(hwnd, tPS)
 
            SetBkMode ldc, 1
 
            FillRect ldc, tClientRect, hBrush
 
            DrawEdge ldc, tClientRect, EDGE_BUMP, BF_RECT
 
            tClientRect.Left = tClientRect.Left + 5
            tClientRect.Top = tClientRect.Top + 5
 
            SetTextColor ldc, TITLE_FONT_COLOR
 
            sInputTitle = sInputTitle & vbNewLine & vbNewLine
 
            CreateTitleFont ldc, sInputTitle
 
            DrawText ldc, sInputTitle, Len(sInputTitle), _
            tClientRect, DT_WORDBREAK
 
            SetTextColor ldc, INPUT_FONT_COLOR
 
            CreateInputFont ldc, sInputTitle
 
            tClientRect.Top = tClientRect.Top + 20
 
            DrawText ldc, sInputMessage, Len(sInputMessage), _
            tClientRect, DT_WORDBREAK
 
            Call DeleteObject(hBrush)
 
            ReleaseDC hwnd, ldc
 
            EndPaint hwnd, tPS
 
    End Select
 
    [COLOR=seagreen][B]'process other msgs.[/B][/COLOR]
    CallBackProc = CallWindowProc _
    (lPrevWnd, hwnd, MSG, wParam, ByVal lParam)
 
End Function
 
Private Sub CreateTitleFont(DC As Long, text As String)
 
    Dim uFont As LOGFONT
    Dim lNewFont As Long
 
    With uFont
        .lfFaceName = "Arial" & Chr$(0)
        .lfUnderline = True
        .lfHeight = TITLE_FONT_HEIGHT
        .lfWidth = TITLE_FONT_WIDTH
        .lfWeight = IIf(TITLE_FONT_BOLD, 900, 100)
 
    End With
 
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
 
End Sub
 
Private Sub CreateInputFont(DC As Long, text As String)
 
    Dim uFont As LOGFONT
    Dim lNewFont As Long
 
    With uFont
        .lfFaceName = "Arial" & Chr$(0)
        .lfHeight = INPUT_FONT_HEIGHT
        .lfWidth = INPUT_FONT_WIDTH
        .lfWeight = IIf(INPUT_FONT_BOLD, 900, 100)
    End With
 
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
 
End Sub
 
Private Sub FormatDVMsg _
(ByVal MsgTitle As String, ByVal MsgInput As String)
 
    If lPrevWnd = 0 Then
        lPrevWnd = SetWindowLong _
        (lDVhwnd, GWL_WNDPROC, AddressOf CallBackProc)
 
       [COLOR=seagreen][B]'send a Paint Msg to the DV box upon showing up.[/B][/COLOR]
        InvalidateRect lDVhwnd, 0, 0
       [COLOR=seagreen][B]'important!!![/B][/COLOR]
        [COLOR=seagreen][B]' Msg pump for safe subclassing !!!![/B][/COLOR]
        Call MessageLoop
    End If
 
 
End Sub
 
Private Sub MessageLoop()
 
    Dim aMsg As MSG
 
    bXitLoop = False
 
    On Error Resume Next
 
   [COLOR=seagreen][B]'ensure all Msgs are posted during the subclassing.[/B][/COLOR]
    Do While GetMessage(aMsg, 0, 0, 0) And bXitLoop = False
        DoEvents
        PostMessage 0, aMsg.message, aMsg.wParam, aMsg.lParam
    Loop
 
End Sub
 
Public Sub StartTimer _
(ByVal MsgTitle As String, ByVal MsgInput As String)
 
  [COLOR=seagreen][B]  'store the DV imput & title[/B][/COLOR]
   [COLOR=seagreen][B]'messages in global vars.[/B][/COLOR]
 
    sInputTitle = MsgTitle
    sInputMessage = MsgInput
 
   [COLOR=seagreen][B]'initiate SetWindowPos flag.[/B][/COLOR]
    bFirstCall = True
 
   [COLOR=seagreen][B]'timer to run the 'FormatDVMsg' routine.[/B][/COLOR]
   [COLOR=seagreen][B]'required to work async with the Selection_Change[/B][/COLOR]
    [COLOR=seagreen][B]'event.Doesn't put a strain on the system[/B][/COLOR]
    [COLOR=seagreen][B]'as it only runs once upon a cell selection.[/B][/COLOR]
 
    lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
 
End Sub
 
Public Sub ClearHook()
 
    [COLOR=seagreen][B]'cleanUp.[/B][/COLOR]
    bXitLoop = True
    SetWindowLong lDVhwnd, GWL_WNDPROC, lPrevWnd
    lPrevWnd = 0
    lDVhwnd = 0
    bFirstCall = True
 
End Sub
 
Private Sub TimerProc()
 
    lDVhwnd = FindWindowEx _
    (FindWindow("XLMAIN", Application.Caption), _
    0, DV_INPUT_MSG_CLASS, vbNullString)
 
    If lDVhwnd <> 0 Then
        KillTimer 0, lTimerID
        Call FormatDVMsg(ByVal sInputTitle, ByVal sInputMessage)
    End If
 
End Sub

Once the hook is installed, it should work for all cells with DV input massages.

Also, despite using a timer and a msg pump loop, this doesn't add a strain to the system as they are both terminated once the DV cell is desactivated.


Regards.
 
Last edited:
Upvote 0
Wonders never cease!!!

I'm not even going to pretend I've got a clue what any of that is doing.

Dom
 
Upvote 0
Domski said:
Wonders never cease!!!

I'm not even going to pretend I've got a clue what any of that is doing.

Dom
Click to expand...

Thanks Domski.

What version of excel did you try the code on ? I am curious to know if it works on other than XL 2003.

Regards.
 
Upvote 0
Jaafar-

I copied and pasted the code, but when I click on a cell with a VD input message the whole workbook closes. I am kind of a newbie when it comes to VBA, so I'm not sure if I am doing something wrong.

Thoughts?

Thanks!
-Toby
 
Upvote 0
ybot said:
Jaafar-

I copied and pasted the code, but when I click on a cell with a VD input message the whole workbook closes. I am kind of a newbie when it comes to VBA, so I'm not sure if I am doing something wrong.

Thoughts?

Thanks!
-Toby
Click to expand...

Did you paste the code in the relevant modules as stated on my post ? ie: first one on the worksheet module and the second on a standard module .

Also, what excel/office version do you have ?

Why not download the Workbook Demo in the link and see if it works or if you still get the same problem .

Regards.
 
Upvote 0
Jaafar Tribak said:
Did you paste the code in the relevant modules as stated on my post ? ie: first one on the worksheet module and the second on a standard module .

Also, what excel/office version do you have ?

Why not download the Workbook Demo in the link and see if it works or if you still get the same problem .

Regards.
Click to expand...


Hi Jaafar,

I really appreciate your code that you posted on this site!!!

However, is there any way to designate the location of the input message box of data validation to a specific location on the sheet upon opening your document??

I know you can move the input message box around of the data validation, but I am looking for a more secure position of it.

Do you think that this is possible to include this in your current code posted here?? or Is this a question for a new thread??


Thanks again,

Pinaceous
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Input Message in Cell via input box
Replies
7
Views
86
Joe4
Joe4
M
  • Solved
Input box triggered when specific value selected from data validation list.
Replies
5
Views
360
Peter_SSs
Peter_SSs
D
  • Solved
Set Focus Not Working
Replies
3
Views
103
Denny57
D
K
  • Solved
How can I show an error message through data validation when the cell is auto populated
Replies
7
Views
382
Micron
M
N
  • Question Question
EXCEL VBA COMBO BOX/DROP DOWN LIST
Replies
1
Views
64
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,910
Messages
6,175,320
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top