Formatting the Data Validation Message Box

[ybot]

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

 

[Jaafar Tribak]

@Pinaceous.

You mean positionning the DV inputbox relative to a specific Cell ? or relative to the screen ?

I think I should be able to edit the existing code to add that functionality but It will need sometime as I would also have to adapt the entire code to work with 64bit excel which is the edition that I am using at the moment.

 

[Pinaceous]

Hi Jaafar,

I am meaning positioning the DV inputbox relative to the screen. For example, I would like the DV inputbox to be stationary at the top of the worksheet. Every time I move the DV inputbox to the top of the worksheet upon restart excel resets the DV inputbox back to its original position in trailing the selected cells. I think it would be cool to have the DV inputbox displaying the selected cell up at the header and not tagging along with the selected cells.

Please let me know, if this is even possible.


Thanks,

Pinaceous

 

[Jaafar Tribak]

Hi,

At the top of the worksheet is vague.. can you specify where ? It along the first visible row ?

Also, bear in mind that manually re-positionning the DV inputbox requires the user intervation only once and any subsequent selection of cells with data validation will show the InputBox at the new location so it is not a big deal.

 

[Pinaceous]

Hi Jaafar,

Yes theoretically I'd like to designate B2:D4 as the DV Inputbox display area.

I do know that one can move it to where they like, which is really no big deal. But you'll have to agree that reopening up the document, with the DV inputbox where you left it last would a big accomplishment, don't you think?

I know I've seen posts about this subject and there seems to be more questions about this then there are answers that I've found anyways.

Thank you for your post.

Respectively,
Pinaceous

 

[Jaafar Tribak]

See if this works for you :

Code to be placed in the ThisWorkbook Module so that it works throughout the entire Workbook for every cell that has a Data Validation Input Message :

Option Explicit

Private 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
    Private 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
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    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 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
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private hwnd As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private 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
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex 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 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
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private hwnd As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

Private Const SM_CXFRAME = 32
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72
Private Const TARGET_RANGE_ANCHOR As String = "B2:D4" [B][COLOR=#008000]'<== change this addrs as required.[/COLOR][/B]


Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call Move_DV_Input_Message_To(Range(TARGET_RANGE_ANCHOR))
End Sub


Private Sub Move_DV_Input_Message_To(ByVal TargetRange As Range)

    Dim tRngRect As RECT
    Dim tHwndRect As RECT
    
    hwnd = FindWindowEx(Application.hwnd, 0, "EXCELA", vbNullString)
    If hwnd Then
        ShowWindow hwnd, 0
        tRngRect = GetRangeRect(TargetRange)
        Call GetWindowRect(hwnd, tHwndRect)
        If EqualRect(tRngRect, tHwndRect) = 0 Then
            With tRngRect
                MoveWindow hwnd, .Left, .Top + GetSystemMetrics(SM_CXFRAME), .Right - .Left, .Bottom - .Top, 1
            End With
            ShowWindow hwnd, 1
        End If
    End If
End Sub

Private Function GetRangeRect(ByVal rng As Range) As RECT
    Dim OWnd  As Window
    
    Set OWnd = rng.Parent.Parent.Windows(1)
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function

Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Private Function ScreenDPI(bVert As Boolean) As Long
    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

 

[Pinaceous]

Wow wow wow wow wow! Thanks, I'm going to try it out this afternoon thanks!

 

[Jaafar Tribak]

Hi Pinaceous,

You may have noticed with my last code that when selecting with the mouse a cell that has a DV Input message, the Input message brievely appears in its default location (ie: beside the cell) before finally moving over the range "B2:D4" ..If this is an issue, it could be avoided by using a timer . I'll post the code later for the sake of completness.

 

[Pinaceous]

Hi Jaafar,

Excellent work on the DV Input message! I'm sure a lot of people will gravitate to this thread to reference your code as I've noticed it being an issue on threads since 2010.

I also noticed something in your code addition to your:

that has a DV Input message, the Input message brievely appears in its default location (ie: beside the cell) before finally moving over the range "B2:D4"

Let me explain; I'm working with a table Range B11:U180 with all the cells having a DV Input message. Okay, so around row 23 forward, I've noticed that the designated DV Input message starts to move off the screen, slowly, slowly, slowly, as the row count increases, in starting with row 23 until it finally moves off the screen altogether around row 39.

I just wanted to bring this to your attention before you

post the code later for the sake of completeness.

Again, this code is a real work of art and I am still flawed!

Pinaceous

 

[Jaafar Tribak]

Hi Pinaceous,

Let me explain; I'm working with a table Range B11:U180 with all the cells having a DV Input message. Okay, so around row 23 forward, I've noticed that the designated DV Input message starts to move off the screen, slowly, slowly, slowly, as the row count increases, in starting with row 23 until it finally moves off the screen altogether around row 39.

Yes. That's because as you move down the worksheet from row 23 to 39, the range B2:D4 moves up in the opposite direction until it is off-screen. That's an issue which should be solved by positionning the DV Input message NOT over range B2:D4 but over the screen region that is currently occupied by that range.

In order to achieve this, you will need to make the DV Input message stick in relation to the rectangular screen area delimited by Row2;Col2;Row4;Col4 relative to the currently Visible Range.

So therefore, our previous Move_DV_Input_Message_To Routine will now have the following signature :

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

And this is how you will call the routine for your target Range "B2:D4" :

Call Move_DV_Input_Message_To(VisibleRow:=2, VisibleColumn:=2, RowSize:=3, ColumnSize:=3)

Anyways, here is the entire Timer code\approach:

Code In a Standard Module :

(Run the "Start" Macro to activate the timer -- Run the "Finsih" Macro when done or Before Closing the Workbook)

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
    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
    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 lVisibleRow As Long, lVisibleCol As Long
Dim lXOffset As Long, lYOffset As Long

Sub Start()
    Call Move_DV_Input_Message_To(VisibleRow:=2, VisibleColumn:=2, RowSize:=3, ColumnSize:=3)
End Sub

Sub Finish()
    KillTimer Application.hwnd, 0 [B][COLOR=#008000]'<== IMPORTANT!! MUST BE RAN BEFORE CLOSING THE WORKBOOK.[/COLOR][/B]
End Sub

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

    lVisibleRow = VisibleRow: lVisibleCol = VisibleColumn
    lXOffset = RowSize: lYOffset = ColumnSize
    
    KillTimer Application.hwnd, 0
    SetTimer Application.hwnd, 0, 0, AddressOf TimerProc
End Sub

Sub TimerProc()

    Dim tRngRect As RECT
    
    On Error Resume Next
    If ActiveWorkbook Is ThisWorkbook Then
        hwnd = FindWindowEx(Application.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
                    ShowWindow hwnd, 0
                    ShowWindow hwnd, 1
                End With
            End If
        End If
    End If
End Sub

Function GetRangeRect(ByVal rng As Range) As RECT

    Dim OWnd  As Window
    Dim R As RECT
    
    GetWindowRect 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

    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
    
End Function

Function ScreenDPI(bVert As Boolean) As Long

    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

Notice:
This code uses a Windows Timer so it is imperative that the Timer is propperly killed before closing the workbook otherwise it may cause excel to crash.

I am thinking to write code to have this timer execute out of process from a hidden new instance of excel to avoid all the known potential issues related to using windows timers in VBA ... I'll give this a shot later and if anything promising comes up, I'll post it here later for the record.

 

[Pinaceous]

Hello Jaafar Tribak,


That is sooooo cooooool! This is really a work of computing art!


If you make any additional changes to your code, I'll be sure to subscribe to your updates!




Really great job!


Respectfully,

Pinaceous