basReplaceFonts

' basReplaceFonts() Version 1.0.0
' Copyright © 2023 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
'
Public Function ReplaceFontsInDatabase(OldFonts As String, NewFont As String) As Boolean
' This procedure replaces OldFonts with NewFont in all forms and reports.
' OldFonts is a comma delimited list of font names, like "MS Sans Serif, System".
On Error GoTo Err_Handler
    
    Dim aob As AccessObject
    
    ' Forms
    For Each aob In CurrentProject.AllForms
        Debug.Print aob.Name
        DoEvents
        
        ReplaceFontsInForm aob.Name, OldFonts, NewFont
    Next aob
    
    ' Reports
    For Each aob In CurrentProject.AllReports
        Debug.Print aob.Name
        DoEvents
        
        ReplaceFontsInReport aob.Name, OldFonts, NewFont
    Next aob

    ReplaceFontsInDatabase = True

Exit_Proc:
    On Error Resume Next
    Set aob = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "ReplaceFontsInDatabase()"
    ReplaceFontsInDatabase = False
    Resume Exit_Proc

End Function
'
Public Function ReplaceFontsInForm(FormName As String, OldFonts As String, _
    NewFont As String) As Boolean
' This procedure replaces OldFonts with NewFont in a form.
' OldFonts is a comma delimited list of font names, like "MS Sans Serif, System".
On Error GoTo Err_Handler
    
    Dim frm As Form
    Dim ctl As Control
    Dim strOldFont As String
    Dim avarOldFonts
    Dim intElem As Integer
    
    ' Get an array of old fonts.
    avarOldFonts = Split(OldFonts, ", ")
    
    DoCmd.OpenForm FormName, acDesign, , , , acHidden
    Set frm = Forms(FormName)

    ' Loop through the controls.
    For Each ctl In frm.Controls
        strOldFont = ""
        On Error Resume Next
        strOldFont = ctl.FontName
        If Err = 0 Then
            On Error GoTo Err_Handler
            For intElem = 0 To UBound(avarOldFonts)
                If strOldFont = avarOldFonts(intElem) Then
                    ctl.FontName = NewFont
                    Exit For
                End If
            Next intElem
        Else
            Err.Clear
            On Error GoTo Err_Handler
        End If
    Next ctl
    
    ' Save the form
    DoCmd.Close acForm, FormName, acSaveYes

    ReplaceFontsInForm = True

Exit_Proc:
    On Error Resume Next
    Set ctl = Nothing
    Set frm = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "ReplaceFontsInForm()"
    ReplaceFontsInForm = False
    Resume Exit_Proc
End Function
'
Public Function ReplaceFontsInReport(ReportName As String, OldFonts As String, _
    NewFont As String) As Boolean
' This procedure replaces OldFonts with NewFont in a report.
' OldFonts is a comma delimited list of font names, like "MS Sans Serif, System".
On Error GoTo Err_Handler
    
    Dim rpt As Report
    Dim ctl As Control
    Dim strOldFont As String
    Dim avarOldFonts
    Dim intElem As Integer
    
    ' Get an array of old fonts.
    avarOldFonts = Split(OldFonts, ", ")
    
    DoCmd.OpenReport ReportName, acViewDesign, , , acHidden
    Set rpt = Reports(ReportName)

    ' Loop through the controls.
    For Each ctl In rpt.Controls
        strOldFont = ""
        On Error Resume Next
        strOldFont = ctl.FontName
        If Err = 0 Then
            On Error GoTo Err_Handler
            For intElem = 0 To UBound(avarOldFonts)
                If strOldFont = avarOldFonts(intElem) Then
                    ctl.FontName = NewFont
                    Exit For
                End If
            Next intElem
        Else
            Err.Clear
            On Error GoTo Err_Handler
        End If
    Next ctl
    
    ' Save the form
    DoCmd.Close acReport, ReportName, acSaveYes

    ReplaceFontsInReport = True

Exit_Proc:
    On Error Resume Next
    Set ctl = Nothing
    Set rpt = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "ReplaceFontsInReport()"
    ReplaceFontsInReport = False
    Resume Exit_Proc
End Function