Centering a Form's Caption

Centering a Form's Caption

If you are using a form that is not maximized, you may wish to have the caption centred. There are several ways of doing this:

Manually enter spaces before the caption text until it looks 'right';
Calculate the number of characters in the caption and the form's width, and pad with blank spaces;
Calculate the width of the characters in the caption and the form's width, and pad with blank spaces;

Below is some code to achieve the last option. Unfortunately, it does not deal with the fact that the user may have altered the font for the active caption from MS Sans Serif 8.

Option Compare Database
Option Explicit

Private Const LOGPIXELSX = 88
Private Const TWIPSPERINCH = 1440

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

Private Type POINTAPI
    x As Long
    y 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 SIZE
    cx As Long
    cy As Long
End Type

Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
    (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function apiGetDC Lib "user32" Alias "GetDC" _
    (ByVal hwnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" _
    (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function apiGetTextExtentPoint Lib "gdi32" Alias "GetTextExtentPointA" _
    (ByVal hdc As Long, ByVal lpszString As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function apiGetWindowPlacement Lib "user32" Alias "GetWindowPlacement" _
    (ByVal hwnd As Long, lpwndpl As WINDOWPLACEMENT) As Long
Private Declare Function apiIsZoomed Lib "user32" Alias "IsZoomed" _
    (ByVal hwnd As Long) As Long

Sub sCentreCaption(strForm As String)
'   Procedure to centre the caption of a non-maximized Access form.
'   Accepts:
'       strForm - the name of the form that is being dealt with
'   Notes:
'       code should be called in the Resize event, as in sCentreCaption Me.Name
'       Assumes that the font size for the caption is 8
'       Ignores the width of the control buttons
    On Error GoTo E_Handle
    Dim frm As Form
    Dim strCaption As String
    Dim lngFormWidth As Long
    Dim lngCaptionWidth As Long
    Dim lngSpaceWidth As Long
    Dim intSpaces As Integer
    If IsLoaded(strForm) Then
        Set frm = Forms(strForm)
        If Not fFormMax(frm.hwnd) Then
            strCaption = Trim(frm.Caption)
            lngCaptionWidth = fCharacterWidth(strCaption)
            lngFormWidth = fFormWidth(frm.hwnd)
            lngSpaceWidth = fCharacterWidth(" ")
            intSpaces = ((lngFormWidth - lngCaptionWidth) / 2) / lngSpaceWidth
            frm.Caption = Space(intSpaces) & strCaption
        Else
            strCaption = Trim(frm.Caption)
            lngCaptionWidth = fCharacterWidth(strCaption)
            lngFormWidth = fFormWidth(Application.hWndAccessApp)
            lngSpaceWidth = fCharacterWidth(" ")
            intSpaces = ((lngFormWidth - lngCaptionWidth) / 2) / lngSpaceWidth
            frm.Caption = Space(intSpaces) & strCaption
        End If
    End If
sExit:
    On Error Resume Next
    Set frm = Nothing
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & "sCentreCaption", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume sExit
End Sub

Private Function IsLoaded(ByVal strFormName As String) As Boolean
'   Returns True if the specified form is open in Form view or Datasheet view.
'   Code from Northwind sample database
    Const conObjStateClosed = 0
    Const conDesignView = 0
    If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
        If Forms(strFormName).CurrentView <> conDesignView Then
            IsLoaded = True
        End If
    End If
End Function

Private Function fFormMax(lngWindowHandle) As Boolean
'   Function to check if an Access form is maximized or not
'   Accepts:
'       lngWindowHandle: The Window Handle for a form
'   Returns:
'       True if the form is maximized, otherwise False
    Dim lngReturn As Long
    lngReturn = apiIsZoomed(lngWindowHandle)
    fFormMax = lngReturn
End Function

Private Function fFormWidth(lngWindowHandle As Long) As Long
'   Function to return the width of an Access form
'   Accepts:
'       lngWindowHandle: The Window Handle for a form
'   Returns:
'       The width of the form in pixels
    Dim frm As Form
    Dim lngReturn As Long
    Dim typWindow As WINDOWPLACEMENT
    Dim typRect As RECT
    typWindow.Length = Len(typWindow)
    lngReturn = apiGetWindowPlacement(lngWindowHandle, typWindow)
    typRect = typWindow.rcNormalPosition
    sTwipsToPixels typRect.Left
    sTwipsToPixels typRect.Right
    fFormWidth = Abs(typRect.Left - typRect.Right)
End Function

Private Function fCharacterWidth(strChar As String) As Long
'   Function to calculate the width of text
'   Accepts:
'       strChar: A string containing text
'   Returns:
'       The width of the text in pixels
    On Error GoTo E_Handle
    Dim lngReturn As Long
    Dim lngHDC As Long
    Dim lngWindowHandle As Long
    Dim lngPixelsPerInch As Long
    Dim typSize As SIZE
    lngWindowHandle = Application.hWndAccessApp
    lngHDC = apiGetDC(lngWindowHandle)
    lngReturn = apiGetTextExtentPoint(lngHDC, strChar, Len(strChar), typSize)
    sTwipsToPixels typSize.cx
    fCharacterWidth = typSize.cx
    lngReturn = apiReleaseDC(lngWindowHandle, lngHDC)
fExit:
    On Error Resume Next
    Exit Function
E_Handle:
    MsgBox Err.Description & vbCrLf & "fCharacterWidth", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume fExit
End Function

Private Sub sTwipsToPixels(lngX As Long)
'   Procedure to convert twips to pixels
'   Accepts:
'       lngX: Number of twips horizontally
'   Returns:
'       Nothing directly, but modifies the values passed
    On Error GoTo E_Handle
    Dim lngHDC As Long
    Dim lngReturn As Long
    lngHDC = apiGetDC(0)
    lngReturn = apiGetDeviceCaps(lngHDC, LOGPIXELSX)
    lngX = lngX / lngReturn * TWIPSPERINCH
sExit:
    On Error Resume Next
    lngReturn = apiReleaseDC(0, lngHDC)
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & "sPixelsToInches", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume sExit
End Sub

Top

Last modified at 06/06/2006 14:53:16