Changing Colour Of Data Validation Input Boxes

A

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
4,564
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Purely aesthetic ....

I know you can code the changing of Excel's comment box background colour, but can you do it for the dialogue boxes associated with data validation input messages? The default is the yellow, but wondering if its possible to change its colour.
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
Not to my knowledge
But here is a workaround, using a textbox to display the message.
- format the textbox with aesthetic choice of colour

www.contextures.com

How to Show Data Validation Messages in Textbox

For Excel data validation, show messages to the user by in a text box, at the top of the worksheet
www.contextures.com
 
Upvote 0
I am sure I have done this in the past for 32 bit ... I'll adapt the code and post it here later.
 
Upvote 0
See if this works for you :

Workbook Sample

FormatDVInputMsg.gif





1- API code in a Standard Module:
VBA Code: 
Option Explicit

Public Type FORMAT_ATTRIBUTES
    TITLE_FONT_COLOR As Long
    INPUT_FONT_COLOR As Long
    INPUT_BCKG_COLOR As Long
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

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

Type PAINTSTRUCT
    #If VBA7 Then
        hdc As LongPtr
    #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

 Type Msg
    #If VBA7 Then
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
    #Else
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
    #End If
    time As Long
    pt As POINTAPI
End Type

#If VBA7 Then
    #If Win64 Then
        Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    #End If
    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
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
    Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As LongPtr
    Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    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
    Declare PtrSafe Function DrawEdge Lib "user32" (ByVal hdc As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
#Else
    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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 GetActiveWindow Lib "user32" () As Long
    Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As Msg, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
    Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
    Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    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
    Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) 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 KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
#End If


Private bXitLoop As Boolean
Private sInputMessage As String
Private sInputTitle As String
Private tAttributes As FORMAT_ATTRIBUTES




Public Property Let FormatDVInputMessage(ByVal Cell As Range, FormatAttributes As FORMAT_ATTRIBUTES, ByVal Format As Boolean)

    If Format Then
        tAttributes = FormatAttributes
        sInputMessage = Cell.Validation.InputMessage
        sInputTitle = Cell.Validation.InputTitle
        Call SetTimer(Application.hwnd, 0, 0, AddressOf FindInputMessageHwnd)
    Else
        Call ClearHook
    End If

End Property


Private Sub FindInputMessageHwnd()

    #If VBA7 Then
        Dim lDVhwnd  As LongPtr
    #Else
        Dim lDVhwnd  As Long
    #End If
    
    lDVhwnd = FindWindowEx(FindWindow("XLMAIN", Application.Caption), 0, "EXCELA", vbNullString)
    Call SetProp(Application.hwnd, "lDVhwnd", lDVhwnd)
    Call ShowWindow(lDVhwnd, 0)
    Call ShowWindow(lDVhwnd, 1)
    If lDVhwnd <> 0 Then
        Call KillTimer(Application.hwnd, 0)
        Call FormatDVMsg(ByVal sInputTitle, ByVal sInputMessage)
    End If
 
End Sub


Private Sub FormatDVMsg(ByVal MsgTitle As String, ByVal MsgInput As String)

    #If VBA7 Then
            Dim lPrevWnd As LongPtr
    #Else
            Dim lPrevWnd As Long
    #End If
 
    Const GWL_WNDPROC As Long = -4
   
    If GetProp(Application.hwnd, "lPrev") = 0 Then
        lPrevWnd = SetWindowLong(GetProp(Application.hwnd, "lDVhwnd"), GWL_WNDPROC, AddressOf CallBackProc)
        Call SetProp(Application.hwnd, "lPrev", lPrevWnd)
        Call InvalidateRect(GetProp(Application.hwnd, "lDVhwnd"), 0, 0)
        Call MessageLoop
    End If
 
End Sub


#If VBA7 Then
    Private Function CallBackProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Dim hBrush As LongPtr, hdc As LongPtr
#Else
    Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hBrush As Long, hdc As Long
#End If
 
    Const WM_PAINT As Long = &HF&
    Const DT_WORDBREAK = &H10
    Const DT_INTERNAL = &H1000
    Const BDR_SUNKENOUTER = &H2
    Const BDR_RAISEDINNER = &H4
    Const BF_LEFT = &H1
    Const BF_TOP = &H2
    Const BF_RIGHT = &H4
    Const BF_BOTTOM = &H8
    Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
    Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
    
    Dim tClientRect As RECT, tPS As PAINTSTRUCT

    If IsVBEActive Then
        Call ClearHook
        Exit Function
    End If
    
    With tAttributes
        Select Case Msg
            Case WM_PAINT
                Call GetClientRect(hwnd, tClientRect)
                hdc = BeginPaint(hwnd, tPS)
                hBrush = CreateSolidBrush(.INPUT_BCKG_COLOR)
                Call FillRect(hdc, tClientRect, hBrush)
                Call DeleteObject(hBrush)
                Call DrawEdge(hdc, tClientRect, EDGE_ETCHED, BF_RECT)
                Call SetTextColor(hdc, .TITLE_FONT_COLOR)
                tClientRect.Left = tClientRect.Left + 6
                Call CreateFont(hdc, True)
                Call DrawText(hdc, sInputTitle, -1, tClientRect, DT_INTERNAL)
                Call SetTextColor(hdc, .INPUT_FONT_COLOR)
                tClientRect.Top = tClientRect.Top + 20
                Call CreateFont(hdc, False)
                Call DrawText(hdc, sInputMessage, -1, tClientRect, DT_WORDBREAK + DT_INTERNAL)
                Call EndPaint(hwnd, tPS)
        End Select
    End With
    
    CallBackProc = CallWindowProc(GetProp(Application.hwnd, "lPrev"), hwnd, Msg, wParam, ByVal lParam)
 
End Function


Private Sub MessageLoop()
 
    Dim tMsg As Msg
 
    On Error Resume Next
    bXitLoop = False
    Do While GetMessage(tMsg, 0, 0, 0) And bXitLoop = False
        DoEvents
        Call TranslateMessage(tMsg)
        Call DispatchMessage(tMsg)
        Call PostMessage(tMsg.hwnd, tMsg.message, tMsg.wParam, tMsg.lParam)
    Loop

End Sub
 
 
#If VBA7 Then
    Private Sub CreateFont(ByVal DC As LongPtr, ByVal Title As Boolean)
    Dim lNewFont As LongPtr
#Else
    Private Sub CreateFont(ByVal DC As Long, ByVal Title As Boolean)
    Dim lNewFont As Long
#End If

    Dim uFont As LOGFONT
 
    With uFont
        .lfFaceName = "Calibri" & Chr$(0)
        .lfHeight = IIf(Title, 20, 15)
        .lfWeight = IIf(Title, 900, 100)
    End With
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
 
End Sub


Private Sub ClearHook()

    Const GWL_WNDPROC As Long = -4
    
    bXitLoop = True
    If GetProp(Application.hwnd, "lPrev") Then
        Call SetWindowLong(GetProp(Application.hwnd, "lDVhwnd"), GWL_WNDPROC, GetProp(Application.hwnd, "lPrev"))
        Call ShowWindow(GetProp(Application.hwnd, "lDVhwnd"), 0)
        Call RemoveProp(Application.hwnd, "lDVhwnd")
        Call RemoveProp(Application.hwnd, "lPrev")
    End If

 
End Sub


Private Function IsVBEActive() As Boolean
    IsVBEActive = CBool(GetActiveWindow = FindWindow("wndclass_desked_gsk", vbNullString))
End Function

Private Sub Auto_Close()
    Call ClearHook
End Sub



2- Code Usage in the Worksheet Module :
VBA Code: 
Option Explicit


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim tFormatAttributes As FORMAT_ATTRIBUTES
   
    If Target.Cells.Count = 1 Then
        If CellHasDVInputMessage(Target) Then
            With tFormatAttributes
                Select Case Target.Address(0, 0)
                    Case "B4"
                        .TITLE_FONT_COLOR = vbWhite
                        .INPUT_FONT_COLOR = vbWhite
                        .INPUT_BCKG_COLOR = vbBlack
                    Case "F4"
                        .TITLE_FONT_COLOR = vbWhite
                        .INPUT_FONT_COLOR = vbMagenta
                        .INPUT_BCKG_COLOR = vbGreen
                    Case "D9"
                        .TITLE_FONT_COLOR = vbGreen
                        .INPUT_FONT_COLOR = vbYellow
                        .INPUT_BCKG_COLOR = vbRed
                End Select
            End With
            FormatDVInputMessage(Target, tFormatAttributes) = True
        Else
            FormatDVInputMessage(Target, tFormatAttributes) = False
        End If
    Else
        FormatDVInputMessage(Target, tFormatAttributes) = False
    End If

End Sub


Private Function CellHasDVInputMessage(ByVal Cell As Range) As Boolean
    On Error Resume Next
    CellHasDVInputMessage = CBool(Len(Cell.Validation.InputMessage))
End Function
 
Upvote 0
Thank you Jaafar! I really appreciate the effort you put in to provide this for us all. That's quite the code for such a trivial activity, but it supports the concept that VBA can provide for the wildest things.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
VBA to change cell colour based on content
Replies
3
Views
151
Snakehips
Snakehips
M
  • Question
Conditional formatting specifying 5 colours
Replies
7
Views
518
Peter_SSs
Peter_SSs
N
  • Question
Pop Up Unique Values In Dialogue Box macro
Replies
9
Views
137
Akuini
Akuini
H
  • Solved
VBA - If Cell value is changed
Replies
9
Views
457
Joe4
Joe4
N
  • Solved
Pulling certain row values if a number is matched
Replies
2
Views
152
Newbie73
N

Forum statistics

Threads
1,214,643
Messages
6,120,702
Members
448,980
Latest member
CarlosWin

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