MyTetra Share
Делитесь знаниями!
MS Excel - Экспорт Данных запроса (с параметрами) в Excel c простым форматированием "шапки"
Время создания: 16.03.2019 23:43
Раздел: !Закладки - VBA - Access - msa.polarcom.ru - 11 Импорт - Экспорт
Запись: xintrea/mytetra_db_adgaver_new/master/base/1532017349ctukido1u0/text.html на raw.githubusercontent.com

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




Назад ToTop

Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования