First Published 3 Dec 2020 Last Updated 6 Sept 2024 Difficulty level: Moderate
UPDATED 6 Sept 2024 - additional info about the code in Form 1
Access provides a built in 'Center Form' as part of the form property sheet. However this only centres the form in a horizontal direction. The outcomes at times can also be visibly well off-centre.
Over the years, I have acquired / written various code samples that can be used to centre forms in both horizontal and vertical directions.
However, I have found that these do not all give identical results. The outcomes depend on whether:
a) Access is maximised or not (occupies part of the screen only)
b) the navigation pane is maximised/minimised or hidden
c) the forms are popup or not
This article includes two example applications which can be used to compare the results.
From that, you can determine the code that appears to work best for your needs.
Each application contains 4 identical forms (apart from colour). One uses 4 standard forms, the other has 4 popup forms.
Each form is coded so it should open at the centre of the screen (but see below).
Each form is borderless but can be dragged to a new position by holding down the left mouse button on any blank space in the form header.
. You can then click the Re-centre Form button to run the code used again.
NOTE: Click any screenshot to view a larger image
Standard forms
|
Popup forms
|
These are the results obtained with Access maximised after clicking the Re-centre form button on each form
In both examples, forms 3 & 4 give identical centre positions.
For standard forms, form 1 & 2 give very different results. Forms 3 & 4 are both placed close to Form 1
For popup forms, results are more consistent. Forms 1 & 2 are identically positioned with forms 3 & 4 only slightly displaced.
Standard forms
|
Popup forms
|
However, when Access occupies only part of the screen space, results are different again.
Once again, in both examples, forms 3 & 4 give identical centre positions.
For standard forms, form 1 & 2 give very different results with form 2 appearing most central.
Forms 3 & 4 are both shifted well to the bottom right, ignoring the actual size of the Access screen
For popup forms, Forms 1 & 2 are both shifted well to the top left. Forms 3 & 4 appear to be centred correctly!
Standard forms
|
Popup forms
|
Conclusions:
Unfortunately none of the forms give the correct position in all situations
Based on my tests:
For standard forms, form 2 appears to give good results whether or not the form is maximised.
For popup forms, any form is acceptable when the screen is maximised. Forms 3 and 4 are central when only part of the screen is used.
Downloads:
Click to Download:
Centre Form Examples - v1.1 - Not Popup (Approx 0.6 MB zipped)
Centre Form Examples - v2.1 - Popup (Approx 0.6 MB zipped)
Code:
Below is all the code for each form to make it easier to use whichever code you prefer.
Code for Form 1:
Private Sub cmdCentre_Click()
CenterMe Me
End Sub
Private Sub Form_Load()
CenterMe Me
End Sub
Module code - CenterMe (in modCentreForm):
Option Compare Database
Option Explicit
#If VBA7 Then
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Public Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWndPtr As LongPtr, ByVal hDC As LongPtr) As Long
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Const WU_LOGPIXELSX = 88
Public Const WU_LOGPIXELSY = 90
Public Function TwipsPerPixel(strDirection As String) As Long
'Purpose : Get monitor's Twips per pixel
'Handle to device
#If VBA7 Then
Dim lngDC As LongPtr
#Else
Dim lngDC As Long
#End If
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
lngDC = GetDC(0)
If strDirection = "X" Then 'Horizontal
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
Else 'Vertical
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
End If
lngDC = ReleaseDC(0, lngDC)
TwipsPerPixel = nTwipsPerInch / lngPixelsPerInch
End Function
Public Sub WindowSize(ByRef Height As Long, ByRef Width As Long)
'Purpose : Get Access window size.
#If VBA7 Then
Dim hWnd As LongPtr
#Else
Dim hWnd As Long
#End If
Dim rct As RECT
'the project name in line below MUST be the same as the application name
hWnd = FindWindow(vbNullString, Application.VBE.ActiveVBProject.Name)
If hWnd <> 0 And GetWindowRect(hWnd, rct) <> 0 Then
Height = (rct.Bottom - rct.Top) * TwipsPerPixel("Y")
Width = (rct.Right - rct.Left) * TwipsPerPixel("X")
End If
End Sub
Public Function CenterMe(frm As Form)
'Purpose : Center form on screen.
'Requires :
' Code
' TwipsPerPixel()
' WindowSize()
' Type RECT
' API Libraries
' FindWindow
' GetWindowRect
' GetDC
' ReleaseDC
' GetDeviceCaps
Dim lngWinWidth As Long
Dim lngWinHeight As Long
Dim lngFrmWidth As Long
Dim lngFrmHeight As Long
Call WindowSize(lngWinHeight, lngWinWidth)
frm.SetFocus
DoCmd.MoveSize (lngWinWidth - frm.WindowWidth) \ 2, _
(lngWinHeight - frm.WindowHeight) \ 2
End Function
UPDATE: 6 Sept 2024
I was recently contacted by developer mloucel at Centre Access World Forums..
He had discovered that the code for Form1 fails if the application name is different from the VBA project name.
I have confirmed that if these are different, the code fails on the DoCmd.MoveSize line in the CenterMe function the with error 2505:
If this is a problem, use the code from any of the other forms as those are not affected by that issue.
Code for Form 2:
Private Sub cmdCentre_Click()
Form_Load
End Sub
Private Sub Form_Load()
Dim fw As New clFormWindow
fw.hWnd = Me.hWnd
With fw
.Top = (.Parent.Height - .Height) / 2
.Left = (.Parent.Width - .Width) / 2
End With
Set fw = Nothing
End Sub
Module code (based on new instance of class module clFormWindow)
Option Compare Database
Option Explicit
'*************************************************************
' Class module: clFormWindow
'*************************************************************
' Moves and resizes a window in the coordinate system
' of its parent window.
' N.B.: This class was developed for use on Access forms
' and has not been tested for use with other window
types.
'*************************************************************
'*************************************************************
' Type declarations
'*************************************************************
Private Type RECT 'RECT structure used for API calls.
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI 'POINTAPI structure used for API calls.
X As Long
Y As Long
End Type
'*************************************************************
' Member variables
'*************************************************************
Private m_hWnd As Long
'Handle of the window.
Private m_rctWindow As RECT
'Rectangle describing the sides of the last polled location of the window.
'*************************************************************
' Private error constants for use with RaiseError procedure
'*************************************************************
Private Const m_ERR_INVALIDHWND = 1
Private Const m_ERR_NOPARENTWINDOW = 2
'*************************************************************
' API function declarations
'*************************************************************
#If VBA7 Then
Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (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
'Moves and resizes a window in the coordinate system of its parent window.
Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long
'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates.
Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
'Converts lpPoint from screen coordinates to the coordinate system of the specified client window.
Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long
'Returns the handle of the parent window of the specified window.
#Else
Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long
Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (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
'Moves and resizes a window in the coordinate system of its parent window.
Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long
'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates.
Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
'Converts lpPoint from screen coordinates to the coordinate system of the specified client window.
Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long
'Returns the handle of the parent window of the specified window.
#End If
'*************************************************************
' Private procedures
'*************************************************************
Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String)
'Raises a user-defined error to the calling procedure.
Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc
End Sub
Private Sub UpdateWindowRect()
'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow.
Dim ptCorner As POINTAPI
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates.
If Not Me.Parent Is Nothing Then
'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates.
With ptCorner
.X = m_rctWindow.Left
.Y = m_rctWindow.Top
End With
apiScreenToClient Me.Parent.hWnd, ptCorner
With m_rctWindow
.Left = ptCorner.X
.Top = ptCorner.Y
End With
'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates.
With ptCorner
.X = m_rctWindow.Right
.Y = m_rctWindow.Bottom
End With
apiScreenToClient Me.Parent.hWnd, ptCorner
With m_rctWindow
.Right = ptCorner.X
.Bottom = ptCorner.Y
End With
End If
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Sub
'*************************************************************
' Public read-write properties
'*************************************************************
Public Property Get hWnd() As Long
'Returns the value the user has specified for the window's handle.
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
hWnd = m_hWnd
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
Public Property Let hWnd(ByVal lngNewValue As Long)
'Sets the window to use by specifying its handle.
'Only accepts valid window handles.
If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then
m_hWnd = lngNewValue
Else
RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle."
End If
End Property
'----------------------------------------------------
Public Property Get Left() As Long
'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window.
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
Left = m_rctWindow.Left
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Let Left(ByVal lngNewValue As Long)
'Moves the window such that its left edge falls at the position indicated
'(measured in pixels, in the coordinate system of its parent window).
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Get Top() As Long
'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window.
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
Top = m_rctWindow.Top
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Let Top(ByVal lngNewValue As Long)
'Moves the window such that its top edge falls at the position indicated
'(measured in pixels, in the coordinate system of its parent window).
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True
End With
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Get Width() As Long
'Returns the current width (in pixels) of the window.
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
Width = .Right - .Left
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Let Width(ByVal lngNewValue As Long)
'Changes the width of the window to the value provided (in pixels).
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Get Height() As Long
'Returns the current height (in pixels) of the window.
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
Height = .Bottom - .Top
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'----------------------------------------------------
Public Property Let Height(ByVal lngNewValue As Long)
'Changes the height of the window to the value provided (in pixels).
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
UpdateWindowRect
With m_rctWindow
apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True
End With
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
End Property
'*************************************************************
' Public read-only properties
'*************************************************************
Public Property Get Parent() As clFormWindow
'Returns the parent window as a clFormWindow object.
'For forms, this should be the Access MDI window.
Dim fwParent As New clFormWindow
Dim lngHWnd As Long
If m_hWnd = 0 Then
Set Parent = Nothing
ElseIf apiIsWindow(m_hWnd) Then
lngHWnd = apiGetParent(m_hWnd)
fwParent.hWnd = lngHWnd
Set Parent = fwParent
Else
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
End If
Set fwParent = Nothing
End Property
Code for Form 3:
Private Sub cmdCentre_Click()
CentreForm Me
End Sub
Private Sub Form_Load()
CentreForm Me
End Sub
Module code (CentreForm procedure in module modFormInfo)
Option Compare Database
Option Explicit
'===============================================
'Colin Riddington - Mendip Data Systems - 18/02/2019
'Functions to get form dimensions and to reset to default size
'===============================================
Public intWindowLeft As Integer
Public intWindowTop As Integer
Public intInsideHeight As Integer
Public intInsideWidth As Integer
Public intWindowHeight As Integer
Public intWindowWidth As Integer
Public intTotalFormHeight As Integer
Public intTotalFormWidth As Integer
Public intHeightHeader As Integer
Public intHeightDetail As Integer
Public intHeightFooter As Integer
' Public intFormControlBarHeight As Integer
' Public intFormControlBarWidth As Integer
Public intTitleBarHeight As Integer
Public intNavBarHeight As Integer
Public intRecSelWidth As Integer
Public intScrollBarWidth As Integer
Public intScrollBarHeight As Integer
Public frm As Access.Form
Public intBorderWidth As Integer
Public intBorderHeight As Integer
Public intBorderStyle As Integer
Public intScrollbars As Integer
Sub CentreForm(frm As Form)
On Error GoTo Err_Handler
' Determine form's height.
intHeightHeader = frm.Section(acHeader).Height
intHeightDetail = frm.Section(acDetail).Height
intHeightFooter = frm.Section(acFooter).Height
intTotalFormHeight = intHeightHeader + intHeightDetail + intHeightFooter
' Determine form's width.
intTotalFormWidth = frm.Width
'Centre the form on screen
DoCmd.MoveSize (MetricsScreenWidth - intTotalFormWidth) / 2, (MetricsScreenHeight - intTotalFormHeight) / 2 ', intTotalFormWidth, intTotalFormHeight
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " in ResetWindowSize procedure : " & Err.description
Resume Exit_Handler
End Sub
'--------------------------------------------------------
Function GetFormDimensions(frm As Form)
On Error GoTo Err_Handler
'form position
intWindowLeft = frm.WindowLeft
intWindowTop = frm.WindowTop
'form external size
intTotalFormHeight = frm.WindowHeight
intTotalFormWidth = frm.WindowWidth
'form internal size
intInsideHeight = frm.InsideHeight
intInsideWidth = frm.InsideWidth
'section heights
intHeightHeader = frm.Section(acHeader).Height
intHeightDetail = frm.Section(acDetail).Height
intHeightFooter = frm.Section(acFooter).Height
'------------------------------------------------
'get border & title bar height
Select Case frm.BorderStyle
Case 0 'none
intTitleBarHeight = 0
intBorderHeight = 45
Case 1 'thin
intBorderHeight = 45
intTitleBarHeight = 390 '345 title bar + 45 top border
Case 2 'sizable
intBorderHeight = 150
intTitleBarHeight = 495 '345 title bar + 150 top border
Case 3 ' dialog
intBorderHeight = 45
intTitleBarHeight = 390 '345 title bar + 45 top border
End Select
intBorderWidth = intBorderHeight
'------------------------------------------------
'get scrollbar sizes
Select Case frm.ScrollBars
Case 0 'none
intScrollBarHeight = 0
intScrollBarWidth = 0
Case 1 'horiz only
intScrollBarWidth = 0
intScrollBarHeight = 255
Case 2 'vert only
intScrollBarWidth = 255
intScrollBarHeight = 0
Case 3 ' dialog
intScrollBarWidth = 255
intScrollBarHeight = 255
End Select
'If nav buttons visible, horiz scrollbar shares space with nav button bar
If frm.NavigationButtons = True Then
intNavBarHeight = 285
intScrollBarHeight = 0
Else
intNavBarHeight = 0
End If
'------------------------------------------------
If frm.RecordSelectors = True Then
intRecSelWidth = 255
Else
intRecSelWidth = 0
End If
Exit_Handler:
Exit Function
Err_Handler:
' If Err = 5 Then Resume Next
MsgBox "Error " & Err.Number & " in GetFormDimensions procedure : " & Err.description
Resume Exit_Handler
End Function
'--------------------------------------------------------
Sub ResetWindowSize(frm As Form)
On Error GoTo Err_Handler
' Determine form's height.
intHeightHeader = frm.Section(acHeader).Height
intHeightDetail = frm.Section(acDetail).Height
intHeightFooter = frm.Section(acFooter).Height
intTotalFormHeight = intHeightHeader + intHeightDetail + intHeightFooter
' Determine form's width.
intTotalFormWidth = frm.Width
' Determine window's height and width.
intWindowHeight = frm.InsideHeight
intWindowWidth = frm.InsideWidth
'reset to fit intended size
If intWindowWidth <> intTotalFormWidth Then
frm.InsideWidth = intTotalFormWidth
End If
If intWindowHeight <> intTotalFormHeight Then
frm.InsideHeight = intTotalFormHeight
End If
Exit_Handler:
Exit Sub
Err_Handler:
MsgBox "Error " & Err.Number & " in ResetWindowSize procedure : " & Err.description
Resume Exit_Handler
End Sub
IMPORTANT:
To use the code in Form 3, you will also need to import module modMetrics into your own applications.
Code for Form 4:
Private Sub cmdCentre_Click()
CenterForm Me
End Sub
Private Sub Form_Load()
CenterForm Me
End Sub
Module Code - based on CenterForm procedure in module modFormCentre
' (c) Renaud Bompuis, 2008
' Licensed under the Creative Commons Attribution License
' http://creativecommons.org/licenses/by/3.0/
' http://creativecommons.org/licenses/by/3.0/legalcode
' Free for re-use in any application or tutorial providing clear credit
' is made about the origin of the code and a link to the site above
' is prominently displayed where end-user can access it.
' updated for 64bit
'-----------------------------------------------------------------------------
Option Compare Database
Option Explicit
Private Type RECT
X1 As Long
Y1 As Long
X2 As Long
Y2 As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90
Sub CenterForm(f As Form)
Dim formWidth As Long, formHeight As Long
Dim maxWidth As Long, maxHeight As Long
Dim ScreenWidth As Long, ScreenHeight As Long
Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long
' Compute maximal acceptable dialog box size in twips
GetScreenResolution ScreenWidth, ScreenHeight
ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0)
ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0)
maxWidth = ScreenWidth * 0.6
maxHeight = ScreenHeight * 0.9
' Calculate the height and width of the area around the textbox
formAllMarginsHeight = f.WindowHeight - f.Section(acDetail).Height
formAllMarginsWidth = f.Width
' Assess proper width and height of the overall dialog box
formWidth = formAllMarginsWidth
formHeight = formAllMarginsHeight
' Adjust position of the the box to the middle if there is not much text.
If formHeight < f.WindowHeight Then
formHeight = f.WindowHeight
End If
' Redimension the dialog and display the message at the center of the screen
DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight
End Sub
'-----------------------------------------------------------------------------
' Pixel to Twips conversions
'-----------------------------------------------------------------------------
' cf http://support.microsoft.com/default.aspx?scid=kb;en-us;210590
' To call this function, pass the number of twips you want to convert,
' and another parameter indicating the horizontal or vertical measurement
' (0 for horizontal, non-zero for vertical). The following is a sample call:
Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long
'Handle to device
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
#If Win64 Then
Dim lngDC As LongPtr
#Else
Dim lngDC As Long
#End If
lngDC = GetDC(0)
If (lngDirection = 0) Then 'Horizontal
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
Else 'Vertical
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
End If
lngDC = ReleaseDC(0, lngDC)
ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function
'-------------------------------------------------------------
Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long
'Handle to device
Dim lngPixelsPerInch As Long
Const nTwipsPerInch = 1440
#If Win64 Then
Dim lngDC As LongPtr
#Else
Dim lngDC As Long
#End If
lngDC = GetDC(0)
If (lngDirection = 0) Then 'Horizontal
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
Else 'Vertical
lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
End If
lngDC = ReleaseDC(0, lngDC)
ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch
'-------------------------------------------------------------
End Function
Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long)
Dim r As RECT
Dim RetVal As Long
#If Win64 Then
Dim hWnd As LongPtr
#Else
Dim hWnd As Long
#End If
hWnd = GetDesktopWindow()
RetVal = GetWindowRect(hWnd, r)
Width = r.X2 - r.X1
Height = r.Y2 - r.Y1
End Sub
Feedback
Please use the contact form below to let me know whether you found this article useful or if you have any questions.
Please also consider making a donation towards the costs of maintaining this website. Thank you
Colin Riddington Mendip Data Systems Last Updated 6 Sept 2024
Return to Access Articles
Return To Top
|
|
|