AutoFitDatasheet: A Function to Prettify Your Access Datasheets

A picture is worth a thousand words.

How do you go from this...

...to this using only VBA?

With this...

Option Compare Database
Option Explicit

'-------------------------------------------------
'  Declarations for AutoFitDatasheet
Private Type rect
    x1 As Long
    y1 As Long
    x2 As Long
    y2 As Long
End Type

#If VBA7 Then
    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
#Else
    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
#End If
                                                  
#If VBA7 Then
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
#Else
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As rect) As Long
#Else
    Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As rect) As Long
#End If

'API Calls needed to convert twips to pixels
Private Enum imgTwipDirection
    imgTwipHorizontal
    imgTwipVertical
End Enum

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
#Else
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, _
                                                ByVal hDC As LongPtr) As Long
#Else
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
                                                 ByVal hDC As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, _
                                                    ByVal nIndex As Long) As Long
#Else
    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
'-------------------------------------------------

'Automatically resizes the active datasheet window and its columns
'Notes: Works for both tables and select queries that are
'       being displayed in datasheet mode
Sub AutoFitDatasheet()
    Dim Frm As Form
    Set Frm = Screen.ActiveDatasheet


    'Each column on the datasheet is part of its Controls collection
    Dim i As Integer, TotalWidth As Long
    For i = 0 To Frm.Controls.Count - 1
        Const TblDataSheetCellCtlType As Byte = 115
        Const QryDataSheetCellCtlType As Byte = 116
        
        With Frm.Controls(i)
            Select Case .ControlType
            Case TblDataSheetCellCtlType, _
                 QryDataSheetCellCtlType
                
                'bug fix for: https://stackoverflow.com/q/21634017/154439
                'The actual minimum width for a visible column on my
                '   computer is 8 twips, but that may be device-dependent;
                '   25 seems like a safer value
                Const MinVisibleWidth As Long = 25
                Const ColumnAutoFit As Long = -2
                .ColumnWidth = MinVisibleWidth
                .ColumnWidth = ColumnAutoFit
                
                TotalWidth = TotalWidth + .ColumnWidth
            
            Case acSubform
                'Unsupported control type
                '  (opening a query, then switching to design view, then
                '   switching back to design view appears to add an
                '   extra [hidden] subform control)
            
            Case Else
                Debug.Print "Unexpected control type"; .ControlType, .Name
            
            End Select
        End With
        
    Next i
    Frm.Width = TotalWidth

    'These buffer values may be Access version-dependent;
    '   they seem to work well for Access 2019
    Const EdgeWidth As Long = 650
    Const EdgeHeight = 1200
    Const RowHeight = 295

    'Calculate required width and height
    Dim PxWidth As Long, PxHeight As Long
    PxWidth = ConvertTwipsToPixels(TotalWidth + EdgeWidth, imgTwipHorizontal)
    PxHeight = ConvertTwipsToPixels((Frm.Recordset.RecordCount * RowHeight) + EdgeHeight, imgTwipVertical)

    'Get available client size
    Dim MDIRect As rect
    GetClientRect GetParent(Frm.hWnd), MDIRect
    
    'Calculate width and height to use
    Dim Width As Long, Height As Long
    If PxWidth < MDIRect.x2 - MDIRect.x1 Then
        Width = PxWidth
    Else
        Width = MDIRect.x2 - MDIRect.x1
    End If
    If PxHeight < MDIRect.y2 - MDIRect.y1 Then
        Height = PxHeight
    Else
        Height = MDIRect.y2 - MDIRect.y1
    End If

    MoveWindow Frm.hWnd, 0, 0, Width, Height, True
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ConvertTwipsToPixels
' Reference : http://support.microsoft.com/kb/210590
' Date      : 8/12/2008
' Notes     : Function must be called separately for horizontal/vertical dimensions.
'---------------------------------------------------------------------------------------
'
Private Function ConvertTwipsToPixels(lngTwips As Long, _
                                      lngDirection As imgTwipDirection) As Long
    Const nTwipsPerInch = 1440
    
    'Handle to device context
#If VBA7 Then
    Dim hDC As LongPtr
#Else
    Dim hDC As Long
#End If
    hDC = GetDC(0)
    
    Dim lngPixelsPerInch As Long
    If (lngDirection = imgTwipHorizontal) Then    'Horizontal
        lngPixelsPerInch = GetDeviceCaps(hDC, WU_LOGPIXELSX)
    Else    'Vertical
        lngPixelsPerInch = GetDeviceCaps(hDC, WU_LOGPIXELSY)
    End If
    hDC = ReleaseDC(0, hDC)
    ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch

End Function

Image by luciana_ferraz from Pixabay