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
Pinaceous said:
Hi Jaafar,

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

I've been trying to put a
Code: 
MsgBox "Exit !!"
somewhere in my workbook upon the users closing of the document.

I've tried to put it in my ThisWorkbook
Code: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)

Also, I've tried to put it in your
Code: 
Sub Finish()
& in your
Code: 
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
Click to expand...

Are you refering to the code in post #23 ?

If so, I have added a msgbox in the workbook before close event for testing and everything works well as expected . I couldn't reproduce the problem.
 
Upvote 0

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sorry I spoke too soon . You are right the MsgBox is replicated leaving the hidden instance open ... This is not good at all.

Thanks for bringing this issue to my attention.

I'll take a closer look at this later and see if I can remedy it.
 
Upvote 0
In the meantime, replace the previous code with this new one and let me know if the problem is solved :

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()
[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]
    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
        .EnableEvents = False
        .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"))
    
    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
 
Upvote 0
Hi Jaafar!


Thanks for reposting your updated code.

I've managed to put a MsgBox pop up before the workbook closes in ThisWorkbook .

Code: 
 Private Sub Workbook_BeforeClose(Cancel As Boolean)

It seems to do the trick where, it does not get all quantum crazy and executes very nicely before the click on the popup in officially closing the document.

I am happy with this result and hope others my use it to the same satisfaction.

Thanks again!
Pinaceous
 
Upvote 0
Hi Pinaceous,

Did you actually try the last code I posted with the MsgBox inside the Workbook_BeforeClose event ?
 
Upvote 0
Hi Jaafar,

I've tried out your latest code, but nothing poped up in terms of a message box. (?)

I can try it again to test it out on my end.

If I've executed the code improperly on my end, I do apologize in advance.

Thanks,
Pinaceous
 
Last edited:
Upvote 0
Hi Jaafar Tribak,

BTW, your code is still stellar beyond belief.

I would like to apply your code to use on all of the worksheets in a workbook.

I've noticed this part in your code:

Code: 
DV_RANGE:=ThisWorkbook.Sheets("Sheet1").Range("i1:i46"))

Is there anyway to specify this part of your code to all of its sheets in the workbook?

For example, all of the workbook's worksheets.


Thank you!

Paul
 
Upvote 0
Pinaceous said:
Hi Jaafar Tribak,

BTW, your code is still stellar beyond belief.

I would like to apply your code to use on all of the worksheets in a workbook.

I've noticed this part in your code:

Code: 
DV_RANGE:=ThisWorkbook.Sheets("Sheet1").Range("i1:i46"))

Is there anyway to specify this part of your code to all of its sheets in the workbook?

For example, all of the workbook's worksheets.


Thank you!

Paul
Click to expand...



Hi Jaafar,

I've noticed on a previous posted code that you provided, has answered my question.

Thanks again!
Paul
 
Upvote 0
Pinaceous said:
Hi Jaafar,

I've noticed on a previous posted code that you provided, has answered my question.

Thanks again!
Paul
Click to expand...

Hi Paul,

I have discovered an error in the code in the remote excel instance which went unnoticed .

I'll take a look at this later and will post back.
 
Upvote 0
Pinaceous said:
Hi Jaafar Tribak,

BTW, your code is still stellar beyond belief.

I would like to apply your code to use on all of the worksheets in a workbook.

I've noticed this part in your code:

Code: 
DV_RANGE:=ThisWorkbook.Sheets("Sheet1").Range("i1:i46"))

Is there anyway to specify this part of your code to all of its sheets in the workbook?

For example, all of the workbook's worksheets.


Thank you!

Paul
Click to expand...

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
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Input box triggered when specific value selected from data validation list.
Replies
5
Views
283
Peter_SSs
Peter_SSs
D
  • Solved
Set Focus Not Working
Replies
3
Views
89
Denny57
D
K
  • Solved
How can I show an error message through data validation when the cell is auto populated
Replies
7
Views
374
Micron
M
T
  • Question Question
Making a cell mandatory to fill before being able to fill in another cell with a drop-down
Replies
3
Views
114
mumps
mumps
B
  • Question Question
Opening userform
Replies
4
Views
113
RoryA
RoryA

Forum statistics

Threads
1,223,268
Messages
6,171,100
Members
452,379
Latest member
IainTru

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