Модуль для сохранения и восстановления полей и ориентации отчетов

       Используя процедуры данного модуля можно сохранить параметры полей и ориентации отчетов в заданной таблице а потом (в случае чего) - восстанавливать их. Данные хранятся в милиметрах, потому так же можно корректировать поля отчетов прямо в таблице, не открывая макета.

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

' Module : modPeportsParamRestore

' Author : es

' Date : 17.01.04

' Purpose : Модуль для сохранения и восстановления полей и ориентации отчетов

' причем, размеры сохраняются в миллиметрах

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

'Задаем название таблицы для хранения параметров отчетов

Private Const conTableName As String = "xReportsProperties"

'см справочку по Свойству PrtDevMode

Private Type strDevMode

RGB As String * 94

End Type

Private Type tpDevMode

strDeviceName As String * 16

intSpecVersion As Integer

intDriverVersion As Integer

intSize As Integer

intDriverExtra As Integer

lngFields As Long

intOrientation As Integer

End Type

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

'см справочку по Свойству PrtMip

Private Type strPRTMIP

strRGB As String * 28

End Type

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

Private Type tpPRTMIP

lngLeftMargin As Long

lngToptMargin As Long

lngRightMargin As Long

lngBotMargin As Long

lngDataOnly As Long

lngWidth As Long

lngHeight As Long

lngDefaultSize As Long

lngColumns As Long

lngColumnSpacing As Long

lngRowSpacing As Long

lngItemLayout As Long

fFastPrint As Long

fDatasheet As Long

End Type

Private Sub RestoreAllReports()

'Восстанавливает поля и риентацию всех отчетов приложения по сохраненным данным

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

Dim dbs As Database, ctr As Container, doc As Document

Dim lngErr As Long

On Error GoTo RestoreAllReportsErr

Set dbs = CurrentDb

Set ctr = dbs.Containers!Reports

'цикл по всем отчетам

For Each doc In ctr.Documents

'отображение инфы о тек. отчете в Status Bar

SysCmd acSysCmdSetStatus, "Обрабатываю Отчет: " & doc.name

lngErr = RestoreReport(doc.name)

'При любой ошибке восстановления прекращаем цикл

If lngErr = 0 Then Exit For

Next doc

'Очистка статус бара

SysCmd (acSysCmdClearStatus)

Exit Sub

RestoreAllReportsErr:

MsgBox "Процедура [RestoreAllReports] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number & vbCrLf & _

"При обработке Отчета - " & doc.name, vbCritical

End Sub

Private Function RestoreReport(rptName As String) As Long

'Восстанавливает поля и риентацию заданного в аргументе отчета

'при ошибке возвращает ее код

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

Dim lngLeftMargin As Long

Dim lngTopMargin As Long

Dim lngRightMargin As Long

Dim lngBotMargin As Long

Dim lngColumns As Long

Dim lngColumnSpacing As Long

Dim lngRowSpacing As Long

Dim lngItemLayout As Long

Dim lngOrientation As Long

Dim rpt As Report

Dim strSQL As String

Dim rst As DAO.Recordset

Dim DevString As strDevMode

Dim DM As tpDevMode

Dim strDevModeExtra As String

Dim PrtMipString As strPRTMIP

Dim PM As tpPRTMIP

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

On Error GoTo RestoreReportErr

'Открываем данные нужного отчета

strSQL = "SELECT * FROM " & conTableName & " WHERE ReportName='" & rptName & "'"

Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)

If rst.EOF Then Exit Function 'Если отчет не найден

'Записываем в переменные данные в миллиметрах

With rst

lngLeftMargin = !LeftMargin

lngRightMargin = !RightMargin

lngTopMargin = !TopMargin

lngBotMargin = !BotMargin

lngColumns = !Columns

lngColumnSpacing = !ColumnSpacing

lngRowSpacing = !RowSpacing

lngItemLayout = !ItemLayout

lngOrientation = !Orientation

End With

rst.Close

Set rst = Nothing

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

'Отмена отображения на экране

Application.Echo False

'Скрыто открываем отчет в режиме конструктора

DoCmd.OpenReport rptName, acDesign

Set rpt = Reports(rptName)

'Восстанавливаем ориентацию

If Not IsNull(rpt.PrtDevMode) Then

strDevModeExtra = rpt.PrtDevMode

DevString.RGB = strDevModeExtra

LSet DM = DevString

DM.intOrientation = lngOrientation

LSet DevString = DM

Mid(strDevModeExtra, 1, 94) = DevString.RGB

rpt.PrtDevMode = strDevModeExtra 'Пишем в отчет

End If

'Восстанавливаем поля c переводом миллиметров в твипы

PrtMipString.strRGB = rpt.PrtMip

LSet PM = PrtMipString

PM.lngLeftMargin = lngLeftMargin * 56.7

PM.lngRightMargin = lngRightMargin * 56.7

PM.lngToptMargin = lngTopMargin * 56.7

PM.lngBotMargin = lngBotMargin * 56.7

PM.lngColumns = lngColumns

PM.lngColumnSpacing = lngColumnSpacing * 56.7

PM.lngRowSpacing = lngRowSpacing * 56.7

PM.lngItemLayout = lngItemLayout

LSet PrtMipString = PM

rpt.PrtMip = PrtMipString.strRGB 'Пишем в отчет

Set rpt = Nothing

'Закрываем отчет с сохранением данных

DoCmd.Close acReport, rptName, acSaveYes

'Восстанавливаем отображение

Application.Echo True

'Debug.Print "Отчет: " & rptName & " - восстановлен"

Exit Function

RestoreReportErr:

RestoreReport = Err.Number

Application.Echo True

MsgBox "Процедура [RestoreReport] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

End Function

Private Sub AllReportsToTable()

'Процедура записи параметров всех отчетов в таблицу

'Причем размеры в миллиметрах

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

Dim MipString As strPRTMIP

Dim PM As tpPRTMIP

Dim DevString As strDevMode

Dim DM As tpDevMode

Dim dbs As Database, ctr As Container, doc As Document

Dim rpt As Report

Dim strReportName As String

Dim strDevModeExtra As String

Dim strSQL As String

On Error GoTo AllReportsToTableErr

'Отмена отображения на экране

Application.Echo False

'Создаем таблицу для хранения

CreateReportsPropertiesTable

Set dbs = CurrentDb

Set ctr = dbs.Containers!Reports

For Each doc In ctr.Documents 'Цикл по всем отчетам

strReportName = doc.name

'Открываем отчет

DoCmd.OpenReport strReportName, acViewDesign

'Снимаем параметры

Set rpt = Reports(strReportName)

MipString.strRGB = rpt.PrtMip

LSet PM = MipString

strDevModeExtra = rpt.PrtDevMode

DevString.RGB = strDevModeExtra

LSet DM = DevString

'Закрываем отчет

DoCmd.Close acReport, strReportName

'Строим запрос на добвление в таблицу

strSQL = "INSERT INTO " & conTableName & " " & _

"([ReportName], " & _

"[LeftMargin], " & _

"[RightMargin], " & _

"[TopMargin], " & _

"[BotMargin], " & _

"[Columns], " & _

"[ColumnSpacing], " & _

"[RowSpacing], " & _

"[ItemLayout], " & _

"[Orientation])" & _

" VALUES ('" & strReportName & _

"', '" & CSng(PM.lngLeftMargin / 56.7) & _

"', '" & CSng(PM.lngRightMargin / 56.7) & _

"', '" & CSng(PM.lngToptMargin / 56.7) & _

"', '" & CSng(PM.lngBotMargin / 56.7) & _

"', " & PM.lngColumns & _

", '" & CSng(PM.lngColumnSpacing / 56.7) & _

"', '" & CSng(PM.lngRowSpacing / 56.7) & _

"', " & PM.lngItemLayout & _

", " & DM.intOrientation & ")"

'Добавляем запись

dbs.Execute strSQL

Next doc

AllReportsToTableEnd:

On Error Resume Next

Application.Echo True

Set doc = Nothing

Set ctr = Nothing

Set dbs = Nothing

Exit Sub

AllReportsToTableErr:

Application.Echo True

MsgBox "Процедура [AllReportsToTable] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

End Sub

Private Sub CreateReportsPropertiesTable()

'Процедура создания таблицы для хранения параметров отчетов

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

Dim tdf As TableDef

Dim idx As Index

'Удаляем существующую таблицу (если есть)

On Error Resume Next

CurrentDb.TableDefs.Delete conTableName

Err.Clear

'Создаем новую таблицу

On Error GoTo CreateReportsPropertiesTableErr

Set tdf = CurrentDb.CreateTableDef(conTableName)

With tdf

.Fields.Append .CreateField("ReportName", dbText, 30)

.Fields.Append .CreateField("LeftMargin", dbSingle)

.Fields.Append .CreateField("RightMargin", dbSingle)

.Fields.Append .CreateField("TopMargin", dbSingle)

.Fields.Append .CreateField("BotMargin", dbSingle)

.Fields.Append .CreateField("Columns", dbLong)

.Fields.Append .CreateField("ColumnSpacing", dbSingle)

.Fields.Append .CreateField("RowSpacing", dbSingle)

.Fields.Append .CreateField("ItemLayout", dbLong)

.Fields.Append .CreateField("Orientation", dbLong)

'Создаем уникальный индекс

Set idx = .CreateIndex("Primary Key")

With idx

'Добавление полей в индекс

.Fields.Append .CreateField("ReportName")

.Unique = True 'Уникальный

.Primary = True 'Первичный

End With

.Indexes.Append idx

End With

CurrentDb.TableDefs.Append tdf

Exit Sub

CreateReportsPropertiesTableErr:

MsgBox "Процедура [CreateReportsPropertiesTable] привела к ошибке:" & vbCrLf & _

Err.Description & vbCrLf & " Err#" & Err.Number, vbCritical

End Sub