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

Private Sub ExportQueryToExlel03()

'es 14.06.2018

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

'--------------------------------------------------------------------------

Dim objExcelApp As Object, objWrkBk As Object, objWrkSht As Object

Dim qdf As DAO.QueryDef

Dim rst As DAO.Recordset

Dim i As Integer

On Error GoTo ExportQueryToExlel03_Err

'Устанавливаем запрос

Set qdf = CurrentDb.QueryDefs("qwTest_001")

'Установка параметров запроса (если таковые есть) типа:

' ... WHERE mDate Between [ДатаНачалаПериода] And [ДатаКонцаПериода]

qdf.Parameters(0) = Me!txtДатаНачала

qdf.Parameters(1) = Me!txtДатаОкончания

'Открываем набор записей

Set rst = qdf.OpenRecordset

'--------------------------------------------------------------------------

'Проверка есть ли данные для вывода:

With rst

If .BOF = True And .EOF = True Then 'записей нет

MsgBox "Запрос не вернул записей, экспорт прекращён!", vbExclamation, "Ошибка экспорта данных"

GoTo ExportQueryToExlel03_Bye

End If

End With

'--------------------------------------------------------------------------

'Запуск MS Excel:

Set objExcelApp = CreateObject("Excel.application")

Set objWrkBk = objExcelApp.Workbooks.Add 'Создается новая рабочая книга.

Set objWrkSht = objWrkBk.ActiveSheet 'Устанавливается ссылка на активный рабочий лист (1)

'Или так (с заданием конкретного по индексу):

'Set objWrkSht = objWrkBk.Worksheets(2)

'objWrkSht.Activate

objExcelApp.Visible = True

'Оформление "шапки" данных по названиям полей запроса:

objWrkSht.Rows(1).RowHeight = 24 'Выставляем высоту строки "шапки"

For i = 1 To rst.Fields.Count

With objWrkSht.Cells(1, i)

.Value = rst.Fields(i - 1).Name 'Имя Поля из запроса ...

Select Case i

Case 3 'Выставляем ширину столбца 3 (отдельно)

.Value = "Другое Название Поля:" 'Просто для примера ...

.ColumnWidth = 60

Case Else 'Выставляем одинаковую ширину у остальных столбцов

.ColumnWidth = 20

End Select

.Borders.LineStyle = 1 'xlContinuous 'Разлиновка

.HorizontalAlignment = -4108 'xlHAlignCenter

.VerticalAlignment = -4108 'xlVAlignCenter

.Interior.Color = RGB(243, 244, 245) 'Серый цвет

.Font.Bold = True 'Ну понятно ...

End With

Next

'Вставка данных из Recordset (во вторую строчку):

objWrkSht.Range("A2").CopyFromRecordset rst

ExportQueryToExlel03_Bye:

'Закрываем всё за собой

On Error Resume Next

rst.Close

Set rst = Nothing

Set qdf = Nothing

Set objWrkSht = Nothing

Set objWrkBk = Nothing

Set objExcelApp = Nothing

Err.Clear

Exit Sub

ExportQueryToExlel03_Err:

MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _

"in Sub: ExportQueryToExlel03 in module: [Неизвестный Модуль]", vbCritical, "Error in Application"

Err.Clear

Resume ExportQueryToExlel03_Bye

End Sub