MS Excel - Экспорт Данных в Excel c простым форматированием "шапки"

Private Function ExportDataToExcel(Optional sPathToSave$) As String
'Создаёт книгу Excel с данными на первом листе и простым форматированием "шапки"
'----------------------------------------------------------------
'Пример запуска:
'   ExportDataToExcel "D:\Temp\test01.xls"
'----------------------------------------------------------------
Dim sVal$
Dim objWrkBk As Object, objWrkSht As Object
Dim rst As DAO.Recordset
Dim i As Integer
Dim objExcelApp As Object
   
On Error GoTo ExportDataToExcel_Err
    
'Проверочка на путь
    If sPathToSave = "" Then sPathToSave = CurrentProject.Path & "\test01.xls"
    'Debug.Print sPathToSave
    
'--------------------------------------------------------------------------
    sVal = "SELECT Id, DateCreate, DateUpdate, Owner, Name FROM MSysObjects " & vbCrLf & _
           "WHERE ((Flags=0) AND (Type=1)) ORDER BY Name;"
    Set rst = CurrentDb.OpenRecordset(sVal, dbOpenSnapshot)
'--------------------------------------------------------------------------
'Проверка есть ли данные для вывода:
    With rst
        If .BOF = True And .EOF = True Then 'записей нет
            MsgBox "Запрос не вернул записей, экспорт прекращён!", vbExclamation, "Ошибка экспорта данных"
            GoTo ExportDataToExcel_End
        End If
    End With

    If Dir(sPathToSave) <> "" Then Kill sPathToSave

'--------------------------------------------------------------------------
'Запуск MS Excel:
    If objExcelApp Is Nothing Then
        Set objExcelApp = CreateObject("Excel.Application")
    End If
    
    Set objWrkBk = objExcelApp.Workbooks.Add 'Создается новая рабочая книга.
    Set objWrkSht = objWrkBk.ActiveSheet 'Устанавливается ссылка на активный рабочий лист (1)
    'Или так (с заданием конкретного по индексу):
        'Set objWrkSht = objWrkBk.Worksheets(2)
        'objWrkSht.Activate
        
'Оформление "шапки" данных по названиям полей запроса:
    objWrkSht.Rows(1).RowHeight = 24 'Выставляем высоту строки "шапки"
    For i = 1 To rst.Fields.Count
        With objWrkSht.Cells(1, i)
            If i = 1 Then
                .Value = "No"
            Else
                .Value = rst.Fields(i - 1).Name 'Имя Поля
            End If
            
            Select Case i
                Case 1 To 4     ' Выставляем ширину столбцов 1 - 4
                    .ColumnWidth = 14
                Case 5          ' Выставляем ширину столбца 5 (отдельно)
                    .ColumnWidth = 60
                Case Else       ' Выставляем одинаковую ширину у остальных столбцов
                    .ColumnWidth = 12
            End Select
            
            .Borders.LineStyle = 1               ' 1=xlContinuous - Стиль Разлиновки
            .HorizontalAlignment = -4108         ' xlHAlignCenter
            .VerticalAlignment = -4108           ' xlVAlignCenter
            .WrapText = True                     ' Включить перенос текста
            .Interior.Color = RGB(243, 244, 245) ' Серый цвет фона
            '.Font.Bold = True                    ' Жирный шрифт (опционально)
            .Font.Italic = True                  ' Наклонный шрифт (опционально)
        End With
    Next
        
'Вставка данных из Recordset (во вторую строчку):
    objWrkSht.Range("A2").CopyFromRecordset rst
    objWrkBk.SaveAs sPathToSave
    
'Запрос поддтверждения закрытия
    If MsgBox("Закрыть Excel.Application?", _
        vbYesNo + vbQuestion + vbDefaultButton2, "Закрытие") = vbYes Then
        objWrkBk.Close
    Else
        objExcelApp.Visible = True
        objExcelApp.WindowState = 3 'во весь экран
        objWrkBk.Activate
    End If

    ExportDataToExcel = sPathToSave

ExportDataToExcel_End:
    'Закрываем всё за собой
    On Error Resume Next
    rst.Close
    Set rst = Nothing

    Set objWrkSht = Nothing
    Set objWrkBk = Nothing
    If sPathToSave = "" Then
        objExcelApp.Quit
        Set objExcelApp = Nothing
    End If
    Err.Clear
    Exit Function

ExportDataToExcel_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function ExportDataToExcel.", _
        vbCritical, "Произошла ошибка!"
    'Debug.Print "ExportDataToExcel_Line: " & Erl & "."
    Err.Clear
    Resume ExportDataToExcel_End
End Function