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]

Hi Pinaceous,

I am glad you liked the code and am happy you found it useful ..

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

Yes. like I said in my prvoius post, using a windows timer can potentially crash the application should an unhadled runtime error occur or worse a compile error while the timer is still running... That's the reason why I always try to avoid timers unless I find no other way to accomplish the task.

Running the timer outside of excel such as running it in a second instance of excel is certainly more compilcated to do but the result would definitely be a much safer and stable code and we would at least solve the potential crashings issue because the timer would now run out of process and should any accidental error occur, it would only crash the remote process and leave our application working.

I am in the process of finishing some code which I'll post here later,so keep an eye out

 

[Pinaceous]

Hi Jaafar,

I totally hear you about the stability issues of the timer. I do find myself self-correcting my documents' stringed macros in seeding them with Call Start or Call Finish. In experimenting with my docs with the background always running, I do find myself executing the Sub Finish quite frequently. Yeah, once you have

second instance of excel

working without the timer it seems like the sky is the limit!

Again great coding!

Pinaceous

 

[Jaafar Tribak]

Workbook Demo.

Ok. Just to wrap this up, here is the code that runs the timer from a second invisible instance of excel :

The signature of the Move_DV_Input_Message_To routine is now as follows:

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 _
    )

Notice that I have added an Optional argument: "DV_RANGE" that takes the DV range to which the routine will be applied ... If this argument is left out then the routine will apply to all DV cells throughout the entire application.

The second instance of excel will silently run in the background and will close itself either by running the Finish routine or automatically when it detects that the current workbook is closed... so there should be no worry that it will remain loaded in memory when done.

Now, untentionnally raising a vba error or even pressing the Stop button in the VB Editor while the timer is running should not crash the application.

Anyways, here is the code which goes in a Standard Module:

(Running the Start routine will move and resize the DV Input Messages of all the cells in the range :Sheets("Sheet1").Range("i1:i46") when these cells are selected.)

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 in the range "i1:i46":
    '=================================================================
    ' * (1) Row from the Top
    ' * (1) Col from the Left
    ' * Resize (8) Rows down and (3) Cols accross.[/COLOR][/B]

    Call Move_DV_Input_Message_To(VisibleRow:=2, VisibleColumn:=2, RowSize:=8, ColumnSize:=3, _
    DV_RANGE:=ThisWorkbook.Sheets("Sheet1").Range("i1:i46"))
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() [B][COLOR=#008000]'\\Routine Ran in BOTH excel instances **[/COLOR][/B]
    RemoveProp GetDesktopWindow, "VRow"
    RemoveProp GetDesktopWindow, "VCol"
    RemoveProp GetDesktopWindow, "RowSize"
    RemoveProp GetDesktopWindow, "ColSize"
    RemoveProp GetDesktopWindow, "OleId"
End Sub

Sub On_Open() [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    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() [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    Call CleanUp
    KillTimer Application.hwnd, 0
    ThisWorkbook.Saved = True
    DoEvents
    Application.Quit
End Sub

Sub TimerProc() [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    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"))
    
    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 [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    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 [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    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[B][COLOR=#008000] '\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

Function ScreenDPI(bVert As Boolean) As Long [B][COLOR=#008000]'\\Routine Ran in second excel instance ONLY ![/COLOR][/B]
    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]

Hi Jaafar,

It seems to be working our very nicely! Thanks for putting into your code on where to reduce or increase the DV input message box!

Big help!



R/
Pinaceous

 

[hoangvn79]

How to put a control listbox in validation???

 

[Jaafar Tribak]

How to put a control listbox in validation???

Hi,

What do you mean ? Unnless I misunderstood you ,this code applies to cells with Data Validation not to Control Listboxes .

 

[hoangvn79]

Hii! I want can hook validation of excel only show a column to show many column like: https://youtu.be/gFt5Rv62vZo

 

[hoangvn79]

Hi! Jaafar Tribak
Is there a way to get the value of cell active in edit mode (when typing in active cell), I know the active cell class is "EXCEL6", but I can not get the value???

 

[Pinaceous]

Hi hoangvn79,

On behalf of your YouTube link which is in Portuguese in combination with your question in post #28 , which does not deal with DV, I'd say that you need to open a new thread.

Pin

 

[Pinaceous]

Hi Jaafar,

In response to your Post#28, in using your code I have one request.

I've been trying to put a

MsgBox "Exit !!"

somewhere in my workbook upon the users closing of the document.

I've tried to put it in my ThisWorkbook

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Also, I've tried to put it in your

Sub Finish()

& in your

Sub On_Close()

.

It does not seem to behave well in respect that the message box pops up twice or does weird things like that.

Where could I put a message box upon the close of the document in using your code?

Do you have any ideas?

Thanks very much!
Pinaceous