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
 
Sort by date Sort by votes
Jaafar Tribak said:
Hi Paul,

The following should work for all data validation cells in all worksheets .

So by simply running the Start routine, you will now have the DV input message of all DV cells in all worksheets always displayed on the second row and second Column of the currently Visible Range spanning down 8 rows and accross 3 columns... you can flexibly change the location and size of the DV input message by changing the values of the arguments in the Start routine.

Code in a Standard Module:
Code: 
Option Explicit

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    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 IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    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 GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
    Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
    Declare PtrSafe Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    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 GetDesktopWindow Lib "user32" () As LongPtr
    Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Dim hwnd As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    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 IsWindowVisible Lib "user32" (ByVal hwnd As Long) 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 GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint 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
    Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
    Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
    Declare Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister 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 GetDesktopWindow Lib "user32" () As Long
    Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Dim hwnd As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Const SM_CYFRAME = 33
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Const POINTSPERINCH = 72

Dim oWb As Workbook

Sub Start()
   [B][COLOR=#008000] '=====================================================================
    'Move\Resize DV Input Message for the cells with DV in ALL worksheets:
    '=========================================================[/COLOR][/B]============
   [B][COLOR=#008000] ' * (1) Row from the Top[/COLOR][/B]
    [B][COLOR=#008000]' * (1) Col from the Left[/COLOR][/B]
    [COLOR=#008000][B]' * Resize (8) Rows down and (3) Cols accross.[/B][/COLOR]

    Call Move_DV_Input_Message_To(VisibleRow:=2, VisibleColumn:=2, RowSize:=8, ColumnSize:=3, _
    DV_RANGE:=ActiveWindow.VisibleRange)
End Sub

Sub Finish()
    Dim pUnk As IUnknown
    Dim WB As Workbook
    Dim ClassID(0 To 3) As Long
    
    CoDisconnectObject ThisWorkbook, 0
    RevokeActiveObject CLng(GetProp(GetDesktopWindow, "OleId")), 0
    
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set WB = pUnk
    Set pUnk = Nothing
    If Not WB Is Nothing Then
        On Error Resume Next
        WB.Parent.Run "On_Close"
        Set WB = Nothing
    End If
    Call CleanUp
End Sub

Sub Move_DV_Input_Message_To( _
        ByVal VisibleRow As Long, _
        ByVal VisibleColumn As Long, _
        ByVal RowSize As Long, _
        ByVal ColumnSize As Long, _
        Optional ByVal DV_RANGE As Range _
    )

    Dim ClassID(0 To 3) As Long
    Dim lOleId As Long
    Dim DVRange As Range
    Dim oApp As Application
    
    On Error GoTo xit
    
    If Not DV_RANGE Is Nothing Then Set DVRange = DV_RANGE
    If CBool(GetProp(GetDesktopWindow, "VRow")) Then Exit Sub
    
    SetProp GetDesktopWindow, "VRow", VisibleRow
    SetProp GetDesktopWindow, "VCol", VisibleColumn
    SetProp GetDesktopWindow, "RowSize", RowSize
    SetProp GetDesktopWindow, "ColSize", ColumnSize
    
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
    SetProp GetDesktopWindow, "OleId", lOleId
    
    Set oApp = New Application
    With oApp
        .Workbooks.Open ThisWorkbook.FullName, False, ReadOnly:=True
        If DV_RANGE Is Nothing Then
            .Names.Add "DV_Range", "EmptyDVRange"
        Else
            .Names.Add "DV_Range", DVRange.Address
        End If
        .Run "On_Open"
    End With
    
    Exit Sub
xit:
    oApp.Quit
    Call Finish    
End Sub

Sub CleanUp() '\\Routine Ran in BOTH excel instances **
    RemoveProp GetDesktopWindow, "VRow"
    RemoveProp GetDesktopWindow, "VCol"
    RemoveProp GetDesktopWindow, "RowSize"
    RemoveProp GetDesktopWindow, "ColSize"
    RemoveProp GetDesktopWindow, "OleId"
End Sub

Sub On_Open() '\\Routine Ran in second excel instance ONLY !
    Dim ClassID(0 To 3) As Long
    Dim lOleId2 As Long

    If ThisWorkbook.ReadOnly Then
        Set oWb = GetWorkBook
        If oWb Is Nothing Then
            ThisWorkbook.Saved = True: Application.Quit
        Else
            Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35268}"), ClassID(0))
            Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId2)
            SetTimer Application.hwnd, 0, 0, AddressOf TimerProc
        End If
    End If
End Sub

Sub On_Close() '\\Routine Ran in second excel instance ONLY !
    Call CleanUp
    KillTimer Application.hwnd, 0
    ThisWorkbook.Saved = True
    DoEvents
    Application.Quit
End Sub

Sub TimerProc() '\\Routine Ran in second excel instance ONLY !
    Dim lVisibleRow As Long, lVisibleCol As Long
    Dim lXOffset As Long, lYOffset As Long
    Dim tRngRect As RECT
    Static oPrevActiveCell As Range
    Static b_Within_DV_RANGE As Boolean

    On Error Resume Next
    
    If GetWorkBook Is Nothing Then
        Call On_Close
    End If

    lVisibleRow = CLng(GetProp(GetDesktopWindow, "VRow"))
    lVisibleCol = CLng(GetProp(GetDesktopWindow, "VCol"))
    lXOffset = CLng(GetProp(GetDesktopWindow, "RowSize"))
    lYOffset = CLng(GetProp(GetDesktopWindow, "ColSize"))
    
    Debug.Print oWb.Application.ActiveCell.Address
    
    With oWb.Application
        If .Union(.Range([DV_RANGE]), .ActiveCell).Address = .Range([DV_RANGE]).Address Or Err.Number = 1004 Then
            b_Within_DV_RANGE = False
            hwnd = FindWindowEx(.hwnd, 0, "EXCELA", vbNullString)
            If hwnd Then
                tRngRect = GetRangeRect(.Cells(.ActiveWindow.VisibleRange.Row + lVisibleRow - 1, _
                .ActiveWindow.VisibleRange.Column + lVisibleCol - 1).Resize(lXOffset, lYOffset))
                If IsWindowVisible(hwnd) Then
                    With tRngRect
                        MoveWindow hwnd, .Left - GetSystemMetrics(SM_CYFRAME), .Top, .Right - .Left, .Bottom - .Top, 1
                        If oWb.Application.ActiveCell.Address <> oPrevActiveCell.Address Then
                            ShowWindow hwnd, 0
                            ShowWindow hwnd, 1
                        End If
                    End With
                End If
            End If
        Else
            If b_Within_DV_RANGE = False Then
                .ActiveCell.Validation.ShowInput = False
                .ActiveCell.Validation.ShowInput = True
                b_Within_DV_RANGE = True
            End If
        End If
    End With
    Set oPrevActiveCell = oWb.Application.ActiveCell
    
End Sub

Function GetWorkBook() As Object '\\Routine Ran in second excel instance ONLY !
    Dim pUnk As IUnknown
    Dim ClassID(0 To 3) As Long
    
    Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
    Call GetActiveObject(ClassID(0), 0, pUnk)
    Set GetWorkBook = pUnk
End Function

Function GetRangeRect(ByVal rng As Range) As RECT '\\Routine Ran in second excel instance ONLY !
    Dim OWnd  As Window
    Dim r As RECT
    
    GetWindowRect oWb.Application.hwnd, r
    Set OWnd = rng.Parent.Parent.Windows(1)
    
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0) - (r.Left)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0) - (r.Top)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function

Function PTtoPX(Points As Single, bVert As Boolean) As Long '\\Routine Ran in second excel instance ONLY !
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Function ScreenDPI(bVert As Boolean) As Long '\\Routine Ran in second excel instance ONLY !
    Static lDPI(1), lDC
    
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function
Click to expand...



I LOVE IT! I'm definitely one of your biggest fans!


Many Thanks Again!
Paul
 
Upvote 0

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
You must log in or register to reply here.

Similar threads

T
  • Question
Multiple Checkboxes / Conditional formatting
Replies
5
Views
153
trevolly
T
C
  • Solved
Make Message Box Only Appear Once
Replies
6
Views
131
Joe4
Joe4
B
  • Question
Event code to give message box and change color of auto-shape
Replies
4
Views
176
bh24524
B
C
  • Solved
Source Formatting from a Data Validation
2
Replies
10
Views
242
CantExcel123
C
B
  • Solved
I would like a pop up warning for the new check boxes
Replies
6
Views
390
Beks
B

Forum statistics

Threads
1,215,077
Messages
6,122,991
Members
449,094
Latest member
masterms

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