Option Compare Database
Option Explicit

'Code compiled by Xavier Batlle from various online sources and including code by:
'Mike Wolfe - https://nolongerset.com
'Daniel Pineault - https://devhut.net
'Colin Riddington - https://isladogs.co.uk

'==================================================================================

'GetSystemMetrics32 info: http://msdn.microsoft.com/en-us/library/ms724385(VS.85).aspx
#If VBA7 Then
      Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
      Declare PtrSafe Function IsZoomed Lib "user32" (ByVal hWnd As LongPtr) As Long
      Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Long
      Declare PtrSafe Function SetWindowPos Lib "user32" ( _
            ByVal hWnd As LongPtr, _
            ByVal hWndInsertAfter As LongPtr, _
            ByVal X As Long, _
            ByVal Y As Long, _
            ByVal cx As Long, _
            ByVal cy As Long, _
            ByVal wFlags As Long) As Long
#Else
      Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
      Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
      Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
      Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
            ByVal hWndInsertAfter As Long, _
            ByVal X As Long, _
            ByVal Y As Long, _
            ByVal cx As Long, _
            ByVal cy As Long, _
            ByVal wFlags As Long) As Long
#End If

Public Const P2T = 15 'pixels to twips

#If VBA7 Then
      Dim hWnd As LongPtr
#Else
      Dim hWnd As Long
      #End If

'=======================================

Sub ExtendAccessScreens()

      'extend Access interface across multiple monitors

      Dim X As Long
      Dim Y As Long
      Dim cx As Long
      Dim cy As Long

      'https://www.devhut.net/ms-access-vba-minimizemaximize-access-application/
      'DoCmd.RunCommand acCmdAppMinimize 'Minimize the MS Access Application
      'DoCmd.RunCommand acCmdAppMaximize 'Maximize the MS Access Application
      ' If Access Windows is maximized then this code doesn't work.

      ' Get the handle of the MS Access window
      hWnd = Application.hWndAccessApp
      If IsMaximized(hWnd) Or IsMinimized(hWnd) Then
            DoCmd.RunCommand acCmdAppRestore 'Restore the MS Access Application
      End If

      ' Get the screen dimensions
      X = GetLeftVIRTUALSCREEN
      Y = GetTopVIRTUALSCREEN
      cx = GetVirtualHorizontalResolution
      cy = GetVirtualVerticalResolution

      ' Debug.Print X, Y, cx, cy

      ' Set the window position and size to cover both screens
      SetWindowPos hWnd, 0, X, Y, cx, cy, 0
End Sub

'=======================================

Function RestoreSingleScreen()

'Colin Riddington 20/10/2023

      Dim x As Long
      Dim y As Long
      Dim cx As Long
      Dim cy As Long

      'https://www.devhut.net/ms-access-vba-minimizemaximize-access-application/
      'DoCmd.RunCommand acCmdAppMinimize 'Minimize the MS Access Application
      'DoCmd.RunCommand acCmdAppMaximize 'Maximize the MS Access Application
      ' If Access Windows is maximized then it doesn't work.

      ' Get the handle of the MS Access window
      hwnd = Application.hWndAccessApp
      If IsMaximized(hwnd) Or IsMinimized(hwnd) Then
            DoCmd.RunCommand acCmdAppRestore 'Restore the MS Access Application
      End If

      ' Get the screen dimensions in pixels
      x = GetPrimaryMonitorLeft      'normally zero
     y = GetPrimaryMonitorTop      'normally zero
     cx = GetPrimaryMonitorRight      'normally same as primary horizontal resolution
      cy = GetPrimaryMonitorBottom      'normally same as primary vertical resolution

      'Debug.Print x, y, cx, cy

      'Set the window position and size to cover just the primary monitor screen
      SetWindowPos hwnd, 0, x, y, cx, cy, 0

End Function

'=======================================

Public Function CountMonitors() As Long
      'count the number of monitors
      Const SM_CMONITORS = 80
      CountMonitors = GetSystemMetrics32(SM_CMONITORS)
End Function

'=======================================

Public Function GetVirtualHorizontalResolution() As Long
      'The total width of the virtual screen, in pixels.
      'The virtual screen is the bounding rectangle of all display monitors.
     'The SM_XVIRTUALSCREEN metric is the coordinates for the left side of the virtual screen.

      Const SM_CXVIRTUALSCREEN = 78
      GetVirtualHorizontalResolution = GetSystemMetrics32(SM_CXVIRTUALSCREEN)
End Function

'=======================================

Public Function GetVirtualVerticalResolution() As Long
      'The total height of the virtual screen, in pixels.
      'The virtual screen is the bounding rectangle of all display monitors.
      'The SM_YVIRTUALSCREEN metric is the coordinates for the top of the virtual screen.
      Const SM_CYVIRTUALSCREEN = 79
      GetVirtualVerticalResolution = GetSystemMetrics32(SM_CYVIRTUALSCREEN)
End Function

'=======================================

'===== PRIMARY MONITOR =====

Public Function GetPrimaryMonitorTop() As Long
      'The top edge of the screen of the primary display monitor, in pixels - normally zero
      GetPrimaryMonitorTop = DLookup("Top", "tblMonitors", "PrimaryMonitor = True")
End Function

'=======================================

Public Function GetPrimaryMonitorLeft() As Long
      'The left edge of the screen of the primary display monitor, in pixels - normally zero
      GetPrimaryMonitorLeft = DLookup("Left", "tblMonitors", "PrimaryMonitor = True")
End Function

'=======================================

Public Function GetPrimaryMonitorRight() As Long
      'The right edge of the screen of the primary display monitor, in pixels - normally same as primary horizontal resolution
      GetPrimaryMonitorRight = DLookup("Right", "tblMonitors", "PrimaryMonitor = True")
End Function

'=======================================

Public Function GetPrimaryMonitorBottom() As Long
      'The bottom position of the screen of the primary display monitor, in pixels - normally same as primary vertical resolution
      GetPrimaryMonitorBottom = DLookup("Bottom", "tblMonitors", "PrimaryMonitor = True")
End Function

'=======================================

Public Function GetLeftVIRTUALSCREEN() As Long
      'The coordinates for the left side of the virtual screen.
      Const SM_XVIRTUALSCREEN = 76
      GetLeftVIRTUALSCREEN = GetSystemMetrics32(SM_XVIRTUALSCREEN)
End Function

'=======================================

Public Function GetTopVIRTUALSCREEN() As Long
      'The coordinates for the top of the virtual screen.
      Const SM_YVIRTUALSCREEN = 77
      GetTopVIRTUALSCREEN = GetSystemMetrics32(SM_YVIRTUALSCREEN)
End Function

'=======================================

'Next two items from https://nolongerset.com/get-a-handle-on-window-state/
'Modified 21/10/2023 by Colin Riddington for 64-bit
#If VBA7 Then
      Function IsMaximized(hwnd As LongPtr) As Boolean
#Else
      Function IsMaximized(hwnd As Long) As Boolean
#End If
      IsMaximized = IsZoomed(hWnd) * -1
End Function

'=======================================

#If VBA7 Then
      Function IsMimimized(hwnd As LongPtr) As Boolean
#Else
      Function IsMinimized(hwnd As Long) As Boolean
#End If
      IsMinimized = IsIconic(hWnd) * -1
End Function

Additional code in module modMonitorInfo is used to determine info about each monitor and populate the table tblMonitors.


This code is also very complex but once again can just be used 'as is' without fully understanding how it works.

Option Compare Database
Option Explicit

'########################################
'used to collect monitor info
'Colin Riddington - last updated 18/10/2023
'########################################

#If VBA7 Then 'CR - updated 27/11/2022
      Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
      Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
      Declare PtrSafe Function MonitorFromWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal dwFlags As Long) 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 CreateDC Lib "gdi32" Alias "CreateDCA" _
           (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
      Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
      Declare PtrSafe Function LoadLibraryEx Lib "kernel32.dll" Alias "LoadLibraryExA" (ByVal lpFileName As String, ByVal hFile As LongPtr, ByVal dwFlags As Long) As LongPtr
      Declare PtrSafe Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
      Declare PtrSafe Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
      Declare PtrSafe Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As LongPtr) As Long
      Declare PtrSafe Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As LongPtr, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As Long) As Boolean
      Declare PtrSafe Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As LongPtr, ByRef lpMI As MONITORINFOEX) As Boolean
      Declare PtrSafe Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, _
            ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
      Declare Function GetActiveWindow Lib "user32" () As Long
      Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
      Declare Function MonitorFromWindow Lib "user32" (ByVal hwnd As Long, ByVal dwFlags As Long) 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 CreateDC Lib "gdi32" Alias "CreateDCA" _
            (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
      Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
      Declare Function LoadLibraryEx Lib "kernel32.dll" Alias "LoadLibraryExA" (ByVal lpFileName As String, ByVal hFile As Long, ByVal dwFlags As Long) As Long
      Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
      Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
      Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
      Declare Function EnumDisplayMonitors Lib "user32.dll" (ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Boolean
      Declare Function GetMonitorInfo Lib "user32.dll" Alias "GetMonitorInfoA" (ByVal hMonitor As Long, ByRef lpMI As MONITORINFOEX) As Boolean
      Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
            ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Public Const SM_CMONITORS As Long = 80      ' number of display monitors
Public Const MONITOR_CCHDEVICENAME As Long = 32       ' device name fixed length
Private Const MONITOR_PRIMARY As Long = 1
Private Const MONITOR_DEFAULTTONULL As Long = 0
Private Const MONITOR_DEFAULTTOPRIMARY As Long = 1
Private Const MONITOR_DEFAULTTONEAREST As Long = 2

Public Type RECT
      Left As Long
      Top As Long
      Right As Long
      Bottom As Long
End Type

Public Type MONITORINFOEX
      cbSize As Long
      rcMonitor As RECT
      rcWork As RECT
      dwFlags As Long
      szDevice As String * MONITOR_CCHDEVICENAME
End Type

Public Enum DevCap ' GetDeviceCaps nIndex (video displays)
      HORZSIZE = 4      ' width in millimeters
      VERTSIZE = 6       ' height in millimeters
      HORZRES = 8       ' width in pixels
      VERTRES = 10       ' height in pixels
      BITSPIXEL = 12       ' color bits per pixel
      LOGPIXELSX = 88       ' horizontal DPI (assumed by Windows)
      LOGPIXELSY = 90       ' vertical DPI (assumed by Windows)
      COLORRES = 108       ' actual color resolution (bits per pixel)
      VREFRESH = 116       ' vertical refresh rate (Hz)
End Enum

Dim MonitorID() As String, I As Integer

#If VBA7 Then
      Dim hHandle As LongPtr, hwnd As LongPtr, hdc As LongPtr, hMonitor As LongPtr
#Else
      Dim hHandle As Long, hwnd As Long, hdc As Long, hMonitor As Long
#End If

'items to get the mouse cursor position
Private Type POINTAPI
      x As Long
      y As Long
End Type
Private tPos As POINTAPI

#If VBA7 Then
      Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
      Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If

'=======================================

'Get mouse cursor position
Public Function GetXCursorPos() As Long
      Dim pt As POINTAPI
      GetCursorPos pt
      GetXCursorPos = pt.x
End Function

'=======================================

Public Function GetYCursorPos() As Long
      Dim pt As POINTAPI
      GetCursorPos pt
      GetYCursorPos = pt.y
End Function

'=======================================

Public Function GetCurrentMonitorID() As Integer
      GetCurrentMonitorID = Nz(DLookup("MonitorID", "tblMonitors", "CurrentMonitor=True"), 1)
End Function

'=======================================

Public Sub CheckMonitorInfo()
'---------------------------------------------------------------------------------------

' Procedure:       CheckMonitorInfo
' DateTime:       18/11/2022
' Author:            Colin Riddington
' Purpose:          Used to detect position, size and resolution of all connected monitors

' Data stored in tblMonitors and called in form load of startup form

'---------------------------------------------------------------------------------------

      Dim bytNumOfMonitors As Byte

      'clear & repopulate tblMonitors
      CurrentDb.Execute "DELETE * FROM tblMonitors", dbFailOnError

      DoEvents

      bytNumOfMonitors = CountMonitorId

      For I = 1 To UBound(MonitorID)
           Call SaveMonitorInfo(MonitorID(I), bytNumOfMonitors)
      Next I

End Sub

'=======================================

Public Function CountMonitorId()

      ReDim MonitorID(0)
     ' Of course dual screen systems are not available on all Win versions.
      If FunctionExist("user32.dll", "EnumDisplayMonitors") = True Then
           If EnumDisplayMonitors(&H0, ByVal &H0, AddressOf MonitorEnumProc, &H0) = False Then
                  Failed "EnumDisplayMonitors"
            End If
      End If

      CountMonitorId = UBound(MonitorID)

      ' Debug.Print CountMonitorId

End Function

'=======================================

Private Sub SaveMonitorInfo(ForMonitorID As String, bytNoMonitors As Byte)

     'updated 03/03/2023

     'Reason - fix to replace boolean varaibles with byte for non-English versions of Office
     'Thanks to Jacinto Trilio for alerting me to this issue

     'adds info to tblMonitors
      Dim MONITORINFOEX As MONITORINFOEX
      Dim bytPrimary As Byte, strDevice As String, strName As String, bytCurrent As Byte, strPos As String
      Dim lngLeft As Long, lngTop As Long, lngRight As Long, lngBottom As Long, lngHRes As Long, lngVRes As Long
      Dim lngDPI As Long

      MONITORINFOEX.cbSize = Len(MONITORINFOEX)

      If GetMonitorInfo(CLng(ForMonitorID), MONITORINFOEX) = 0 Then Failed "GetMonitorInfo"

      With MONITORINFOEX
            If .dwFlags And MONITOR_PRIMARY Then
                  bytPrimary = 1 'True
            Else
                  bytPrimary = 0 'False
            End If

            With .rcMonitor
                  lngLeft = .Left
                  lngTop = .Top
                  lngRight = .Right
                  lngBottom = .Bottom
            End With

            lngHRes = lngRight - lngLeft
            lngVRes = lngBottom - lngTop
      End With

      'check which monitor is current
      bytCurrent = IIf(GetXCursorPos >= lngLeft And GetXCursorPos <= lngRight And GetYCursorPos >= lngTop And GetYCursorPos <= lngBottom, 1, 0)

'check monitor position
      Dim strSQL As String

      strSQL = "INSERT INTO tblMonitors ( MonitorID, PrimaryMonitor, MonitorPosition, [Left], [Top], [Right], Bottom, HRes, VRes, CurrentMonitor )" & _
            " SELECT " & I & " AS MonitorID, " & bytPrimary & " AS PrimaryMonitor, '' AS MonitorPosition," & _
            " " & lngLeft & " AS [Left], " & lngTop & " AS [Top], " & lngRight & " AS [Right], " & lngBottom & " AS Bottom," & _
            " " & lngHRes & " AS HRes, " & lngVRes & " AS VRes, " & bytCurrent & " AS CurrentMonitor;"

      'Debug.Print strSQL
      CurrentDb.Execute strSQL, dbFailOnError

End Sub

By comparison, the code in frmMain is very simple:

Private Sub Form_Load()

      'check the monitor arrangement and populate tblMonitorInfo
      CheckMonitorInfo

      blnExtend = False
      cmdRestore.Enabled = False
      cmdExtend.Enabled = True

End Sub

'=======================================

Private Sub cmdExtend_Click()

      'recheck the monitor arrangement and update tblMonitorInfo
      CheckMonitorInfo

     'extend Access interface across all screens
      ExtendAccessScreens
      blnExtend = True

      cmdExtend.Enabled = False
      cmdRestore.Enabled = True

End Sub

'=======================================

Private Sub cmdRestore_Click()

      'recheck the monitor arrangement and update tblMonitorInfo
      CheckMonitorInfo

     'restores Access interface to fill the primary monitor only
      RestoreSingleScreen
      blnExtend = False

      cmdRestore.Enabled = False
      cmdExtend.Enabled = True

End Sub