Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type WINDOWPLACEMENT
Length As Long
flags As Long
showCmd As Long
ptMinPosition As POINTAPI
ptMaxPosition As POINTAPI
rcNormalPosition As RECT
End Type
Private Type MONITORINFO
cbSize As Long
rcMonitor As RECT
rcWork As RECT
dwFlags As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type uData
#If Win64 Then
hOriginalWindow As LongLong
hNewWindow As LongLong
#Else
hOriginalWindow As Long
hNewWindow As Long
#End If
End Type
Private Type ROT_DATA
sGUID As String
OLEInstance As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, lpmi As MONITORINFO) As Long
Private Declare PtrSafe Function MonitorFromWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function EnumDisplayMonitors Lib "user32" (ByVal hDc As LongPtr, lprcClip As Any, ByVal lpfnEnum As LongPtr, dwData As uData) 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 SetWindowPlacement Lib "user32" (ByVal hwnd As LongPtr, ByRef lpwndpl As WINDOWPLACEMENT) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
Private Declare PtrSafe Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
Private Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
Private Declare PtrSafe Function CoCreateGuid Lib "ole32" (pguid As GUID) As Long
Private Declare PtrSafe Function StringFromGUID2 Lib "ole32" (rguid As GUID, ByVal lpsz As LongPtr, ByVal cchMax As Long) As Long
#Else
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetMonitorInfo Lib "user32" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, lpmi As MONITORINFO) As Long
Private Declare Function MonitorFromWindow Lib "user32" (ByVal hWnd As Long, ByVal dwFlags As Long) As Long
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hDc As Long, lprcClip As Any, ByVal lpfnEnum As Long, dwData As uData) 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 SetWindowPlacement Lib "user32" (ByVal hwnd As Long, ByRef lpwndpl As WINDOWPLACEMENT) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As Any) As Long
Private Declare Function RegisterActiveObject Lib "OleAut32" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
Private Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
Private Declare Function CoCreateGuid Lib "ole32" (pguid As GUID) As Long
Private Declare Function StringFromGUID2 Lib "ole32" (rguid As GUID, ByVal lpsz As Long, ByVal cchMax As Long) As Long
#End If
Sub Open_Window_Test()
'Open a new window of the activeworkbook in the second monitor.
OpenNewWindowInSecondMonitor wbk:=ActiveWorkbook
End Sub
Sub Close_Window_Test()
'///////////////////////////////////////////////////////////
' The 'WindowIndex' argument follows the chronological
' order in which the window was opened, from first to last.
' (1) is the original window.
'///////////////////////////////////////////////////////////
'This will close the second activeworkbook window:(WindowIndex:=2)
CloseWindow wbk:=ActiveWorkbook, WindowIndex:=2 '<<== change WindowIndex to suit.
End Sub
'_______________________________________________ helper functions _________________________________________________
Private Sub CloseWindow(ByVal wbk As Workbook, ByVal WindowIndex As Long)
Dim oWind As Window
Set oWind = GetWindowObjFromROT(wbk, WindowIndex)
If Not oWind Is Nothing Then
Call CoDisconnectObject(oWind, 0)
On Error Resume Next
oWind.Close
Call DisconnectFromROT(wbk, WindowIndex)
On Error GoTo 0
If Err.Number Then MsgBox "Window doesn't exist or already closed."
End If
End Sub
Private Sub OpenNewWindowInSecondMonitor(ByVal wbk As Workbook)
Const SM_CMONITORS = 80
Dim oOriginWind As Window, oNewWindow As Window
Dim uRotData As ROT_DATA, dwData As uData
With wbk
If GetSystemMetrics(SM_CMONITORS) > 1 Then
If wbk.Windows.Count = 1 Then
Set oOriginWind = .Windows(1)
dwData.hOriginalWindow = .Windows(1).hwnd
uRotData = AddWindowObjToROT(oOriginWind)
.Names.Add "_Wind1", uRotData.sGUID, False
.Names.Add "_Wind1OleID", uRotData.OLEInstance, False
End If
Set oNewWindow = .NewWindow
dwData.hNewWindow = oNewWindow.hwnd
uRotData = AddWindowObjToROT(oNewWindow)
.Names.Add "_Wind" & wbk.Windows.Count, uRotData.sGUID, False
.Names.Add "_Wind" & wbk.Windows.Count & "OleID", uRotData.OLEInstance, False
Call EnumDisplayMonitors(ByVal 0, ByVal 0, AddressOf Monitorenumproc, dwData)
End If
End With
End Sub
#If Win64 Then
Private Function Monitorenumproc( _
ByVal hMonitor As LongLong, _
ByVal hDc As LongLong, _
lpRect As RECT, _
lParam As uData _
) As Long
#Else
Private Function Monitorenumproc( _
ByVal hMonitor As Long, _
ByVal hDc As Long, _
lpRect As RECT, _
lParam As uData _
) As Long
#End If
Const MONITOR_DEFAULTTONEAREST = &H2&
Const SW_SHOWNORMAL = 1
Dim uMI As MONITORINFO
Dim uWP As WINDOWPLACEMENT
uMI.cbSize = LenB(uMI)
Call GetMonitorInfo(hMonitor, uMI)
If MonitorFromWindow(lParam.hOriginalWindow, MONITOR_DEFAULTTONEAREST) <> hMonitor Then
uWP.Length = Len(uWP)
uWP.showCmd = SW_SHOWNORMAL
Call SetWindowPlacement(lParam.hNewWindow, uWP)
With uMI.rcMonitor
Call MoveWindow(lParam.hNewWindow, .Left, .Top, .Right - .Left, .Bottom - .Top, True)
End With
Monitorenumproc = 0
Else
Monitorenumproc = 1
End If
End Function
Private Function AddWindowObjToROT(ByVal Wind As Window) As ROT_DATA
Const S_OK = 0&
Const ACTIVEOBJECT_WEAK = 1
Dim ClassID(0 To 3) As Long
Dim lOLEInstance As Long
Dim sGUID As String
sGUID = CreateGUID
If CLSIDFromString(StrPtr(sGUID), ClassID(0)) = S_OK Then
If RegisterActiveObject(Wind, ClassID(0), ACTIVEOBJECT_WEAK, lOLEInstance) = S_OK Then
AddWindowObjToROT.sGUID = sGUID
AddWindowObjToROT.OLEInstance = lOLEInstance
End If
End If
End Function
Private Function GetWindowObjFromROT(ByVal wb As Workbook, ByVal WinIndex As Long) As Window
Const S_OK = 0&
Dim pUnk As IUnknown
Dim ClassID(0 To 3) As Long
Dim sGUID As String
On Error Resume Next
sGUID = Evaluate(wb.Names("_Wind" & WinIndex).Name)
On Error GoTo 0
If Len(sGUID) Then
If CLSIDFromString(StrPtr(sGUID), ClassID(0)) = S_OK Then
If GetActiveObject(ClassID(0), 0, pUnk) = S_OK Then
wb.Names("_Wind" & WinIndex).Delete
wb.Names("_Wind" & WinIndex & "OleID").Delete
Set GetWindowObjFromROT = pUnk
End If
End If
Else
MsgBox "Window doesn't exist or already closed."
End If
End Function
Private Sub DisconnectFromROT(ByVal wb As Workbook, ByVal WindowIndex As Long)
Const S_OK = 0&
Dim sGUID As String
sGUID = Evaluate(wb.Names("_Wind" & WindowIndex & "OleID").Name)
If RevokeActiveObject(CLng(Evaluate(wb.Names("_Wind" & WindowIndex & "OleID").Name)), 0) = S_OK Then
'success.
End If
End Sub
Private Function CreateGUID() As String
Dim uGUID As GUID
Call CoCreateGuid(uGUID)
CreateGUID = Space$(38)
Call StringFromGUID2(uGUID, StrPtr(CreateGUID), 39)
End Function
Function NameExists(ByVal wb As Workbook, ByVal sName As String) As Boolean
Dim oName As Name
On Error Resume Next
Set oName = wb.Names(sName)
NameExists = Not oName Is Nothing
End Function
Private Sub auto_close()
Dim oName As Name
For Each oName In Application.Names
If InStr(oName.Name, "_Wind") Or InStr(oName.Name, "OleID") Then
On Error Resume Next
Call RevokeActiveObject(Replace([oName], "=", ""), 0)
On Error GoTo 0
oName.Delete
End If
Next
ThisWorkbook.Save
End Sub
