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