AutosizeColumnWidths for Access

' This is a nice-to-have module for developers and power users.

Option Compare Database
Option Explicit

Public Function AutosizeColumnWidths()
' Autosize column widths of open Table/Query datasheet.
' All columns are processed but the width is based on the currently visible rows.
' Concept from http://wvmitchell.blogspot.com/2010/08/resize-query-columns.html
' This is called by the AutoKeys macro, ^R
' BS 1/23/2018
' BS 9/5/2018:  Added support for the active control being on a form that is in datasheet view.
' BS 9/16/2018: Added support for a memo field configured as RichText.  It will be set at a
'               fixed width.  Special thanks to Jack Stockton and James Pilcher.

    Dim frm As Form
    Dim ctl As Control
    Dim prp As DAO.Property
    Dim T As Single

    On Error GoTo ErrorHandler

    Set frm = Screen.ActiveDatasheet

    If (frm Is Nothing) Then
        ' See if the active control is on a subform.
        Set frm = Screen.ActiveControl.Parent
    End If

    If Not (frm Is Nothing) Then
        If frm.CurrentView = 2 Then    ' DataSheet view

            T = Timer

            'Debug.Print frm.Name, frm.RecordSource
            For Each ctl In frm.Controls
                'Debug.Print frm.name, ctl.name

                Select Case ctl.Name
                    '--- HARD CODED SPECIAL CASES ---  Adjust for the developer preference.
                    ' Check for common fields that typically have a heading that is wider
                    ' than the data, or aren't interesting enough to expand completely.
                    '------- Oracle Data ------
                    Case "EMPLOYEE_NUMBER": ctl.ColumnWidth = 1200
                    Case "GLOBAL_EMPLOYEE_NUMBER": ctl.ColumnWidth = 1500
                    Case "EMPLOYEE_GEN": ctl.ColumnWidth = 1500
                    Case "EXPENDITURE_ENDING_DATE": ctl.ColumnWidth = 1200
                    Case "EXPENDITURE_ENDING_DATE": ctl.ColumnWidth = 1200
                    Case "TERMINATION_DATE": ctl.ColumnWidth = 1200
                    Case "EXPENDITURE_CATEGORY": ctl.ColumnWidth = 1500
                    Case "PROJECT_NUMBER": ctl.ColumnWidth = 1200
                    Case "GDW_PROJECT_NUMBER": ctl.ColumnWidth = 1000
                    Case "FISCAL_YEAR": ctl.ColumnWidth = 600
                    Case "YEAR": ctl.ColumnWidth = 600
                    Case "COST_CENTER": ctl.ColumnWidth = 800
                    Case "GDW_COST_CENTER": ctl.ColumnWidth = 800
                    Case "QUANTITY": ctl.ColumnWidth = 1000
                    Case "EMPSTATUS": ctl.ColumnWidth = 400
                    Case "MATCH_FLAG": ctl.ColumnWidth = 500
                    Case "EXPENDITURE_ITEM_ID": ctl.ColumnWidth = 1200
                    Case "CLIENT_NAME": ctl.ColumnWidth = 4000
                    Case "Tap_UoM": ctl.ColumnWidth = 450

                    Case Else
                        If IsRichText(frm.RecordSource, ctl.Properties("ControlSource")) Then
                            ' Set column to a fixed width because -2 will result in a 1" width on a RichText column.
                            ctl.ColumnWidth = 8000
                        Else
                            ctl.ColumnWidth = -2    ' Set to auto-width based on visible cells in this column
                        End If

                        If ctl.ColumnWidth > 8000 Then
                            ctl.ColumnWidth = 8000    'Prevent width greater than 8000 twips
                        End If

                End Select

                If Timer - T > 1 Then
                    ' If it takes more than a second to process controls, show the hourglass
                    ' and refresh the screen after every second so the user sees it is working.
                    ' This was first developed for a table linked to a large .CSV file.
                    DoCmd.Hourglass True
                    DoEvents
                    T = Timer
                End If
Next_ctl:
            Next ctl

'            Beep    ' Let the user know something ran.  Disable it if you get annoyed.
        End If
    End If

Exit_Function:
    Set ctl = Nothing
    Set frm = Nothing
    DoCmd.Hourglass False
    Exit Function

ErrorHandler:
    If err.Number = 2484 Then
        'There is no active datasheet.
        Resume Next

    ElseIf err.Number = 2474 Then
        'The expression you entered requires the control to be in the active window.
        'Probably no ActiveControl
        Resume Next

    ElseIf err.Number = 2467 Then
        'The expression you entered refers to an object that is closed or doesn't exist.
        'Probably no ActiveControl
        Resume Next

    ElseIf err.Number = 438 Then
        'Object doesn't support this property or method
        Resume Next_ctl

    ElseIf err.Number = 2455 Then
        'You entered an expression that has an invalid reference to the property ControlSource.
        Resume Next_ctl
'        If ctl.Name = "Child0" Then
'            ' Ignore the subdatasheet control
'            Resume Next_ctl
'        Else
'            MsgBox Err.Number & " " & Err.Description & vbCrLf & "in procedure AutosizeColumnWidths", vbOKOnly + vbCritical, "Error"
'            Debug.Print "Error: " & Err.Number & " - " & Err.Description
'            Debug.Print "Control: " & ctl.Name
'            Resume Exit_Function
'            Resume
'        End If
    Else
        MsgBox err.Number & " " & err.Description & vbCrLf & "in procedure AutosizeColumnWidths", vbOKOnly + vbCritical, "Error"
        Debug.Print "Error: " & err.Number & " - " & err.Description
        Debug.Print "Control: " & ctl.Name
        Resume Exit_Function
        Resume
    End If

End Function


Public Function ResetColumnWidths()
' Reset the column widths of open Table/Query datasheet to the default ~1.0" width.
' This is called by the AutoKeys macro, CTRL+SHIFT+R
' Set all Column widths back to -1
' BS 9/16/2018

    Dim frm As Form
    Dim ctl As Control
    Dim prp As DAO.Property

    On Error GoTo ErrorHandler

    Set frm = Screen.ActiveDatasheet

    If (frm Is Nothing) Then
        ' See if the active control is on a subform.
        Set frm = Screen.ActiveControl.Parent
    End If

    If Not (frm Is Nothing) Then
        If frm.CurrentView = 2 Then    ' DataSheet view

'            Debug.Print frm.Name, frm.RecordSource

            For Each ctl In frm.Controls
'                Debug.Print ctl.name
                ctl.ColumnWidth = -1    ' Set to default width
Next_ctl:
            Next ctl

'            Beep    ' Let the user know something ran.
        End If
    End If

Exit_Function:
    Exit Function

ErrorHandler:
    If err.Number = 2484 Then
        'There is no active datasheet.
        Resume Next

    ElseIf err.Number = 438 Then
        'Object doesn't support this property or method
        Resume Next_ctl

    Else
        MsgBox err.Number & " " & err.Description & vbCrLf & "in procedure ResetColumnWidths", vbOKOnly + vbCritical, "Error"
        Resume Exit_Function
        Resume
    End If

End Function



Public Function IsRichText(strTableName As String, strFieldName As String) As Boolean
' Return TRUE if the passed field is Memo/Long Text with the
' Text Format set as "Rich Text"
' This is from James Pilcher and Jack Stockton

    On Error GoTo PROC_ERR

    Dim db  As DAO.Database
    Dim tdf As DAO.TableDef
    Dim qdf As DAO.QueryDef
    Dim fld As DAO.Field
    Dim prp As DAO.Property

    Set db = CurrentDb

    'Test if Table Exists
    If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & strTableName & "' And Type In (1,4,6)")) Then
        Set tdf = db.TableDefs(strTableName)
        Set fld = tdf.Fields(strFieldName)
    Else
        Set qdf = db.QueryDefs(strTableName)
        Set fld = qdf.Fields(strFieldName)
    End If

    If fld.Type = dbMemo Then
        On Error Resume Next
        Set prp = fld.Properties("TextFormat")
        If err.Number = 0 Then
            IsRichText = prp.Value ' 1=Rich Text, 0=Plain Text
        End If
    End If

PROC_EXIT:
    If Not prp Is Nothing Then _
       Set prp = Nothing
    If Not fld Is Nothing Then _
       Set fld = Nothing
    If Not tdf Is Nothing Then _
       Set tdf = Nothing
    If Not qdf Is Nothing Then _
       Set qdf = Nothing
    If Not db Is Nothing Then _
       Set db = Nothing

    Exit Function

PROC_ERR:
    If err.Number = 3265 Then
        Resume PROC_EXIT
        Resume
    ElseIf err.Number = 3075 Or err.Number = 3223 Then
        ' 3075:  Syntax error (missing operator) in query expression <strTableName>
        ' 3223:  <strTableName> is invalid because it is too long, or contains invalid characters.
        ' This happens when strTableName is a SQL statement and is passed to DLookup().
        Resume PROC_EXIT
        Resume Next
    Else
        MsgBox "Error " & err.Number & " (" & err.Description & ") in procedure IsRichText"
        Resume PROC_EXIT
        Resume
    End If
End Function