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

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

'--------------------------------------------------------------------
' Module    : modPeportsParamRestore
' Author    : es
' Date      : 17.01.2004
' 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