ник: час
Или вот ещё целая статья - куча функций на все случаи.......
Коды не мои........ Благодарность авторам.
Вопрос: Модуль восстановления полей и ориентации отчетов
Совет:
Используя функции данного модуля можно сохранить параметры полей и ориентации отчетов в специальной таблице а потом при открытии отчета на печать /просмотр - восстанавливать их.
Option Compare Database
Option Explicit
'===============================================================
'см справочку по Свойству PrtDevMode
'===============================================================
Type str_DEVMODE
RGB As String * 94
End Type
'===============================================================
Type type_DEVMODE
strDeviceName As String * 16
intSpecVersion As Integer
intDriverVersion As Integer
intSize As Integer
intDriverExtra As Integer
lngFields As Long
intOrientation As Integer
'Используем пока только Orientation -
End Type
'===============================================================
'см справочку по Свойству PrtMip
Type str_PRTMIP
strRGB As String * 28
End Type
'===============================================================
Type type_PRTMIP
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
Function jsOpenReport(MyReportName As String, Optional MyMode As Byte = 1)
'если MyMode=1 - Печать
'если MyMode=2 - Просмотр
'если MyMode=3 - Только Восстановление параметров
On Error GoTo jsOpenReportErr
Dim MyLeftMargin As Long
Dim MyTopMargin As Long
Dim MyRightMargin As Long
Dim MyBotMargin As Long
Dim MyColumns As Long
Dim MyColumnSpacing As Long
Dim MyRowSpacing As Long
Dim MyItemLayout As Long
Dim MyOrientation As Long
Dim rpt As Report
Dim MySQL As String
Dim MyRst As DAO.Recordset
Dim DevString As str_DEVMODE
Dim DM As type_DEVMODE
Dim strDevModeExtra As String
Dim PrtMipString As str_PRTMIP
Dim PM As type_PRTMIP
' ++++++++++++++++++++++++++++++++++
Application.Echo False
MySQL = "SELECT * FROM A_ReportsPprt" & _
" WHERE ReportName='" & MyReportName & "';"
Set MyRst = CurrentDb.OpenRecordset(MySQL, dbOpenSnapshot)
If MyRst.EOF Then Exit Function
With MyRst
MyLeftMargin = !LeftMargin
MyRightMargin = !RightMargin
MyTopMargin = !TopMargin
MyBotMargin = !BotMargin
MyColumns = !Columns
MyColumnSpacing = !ColumnSpacing
MyRowSpacing = !RowSpacing
MyItemLayout = !ItemLayout
MyOrientation = !Orientation
End With
MyRst.Close
Set MyRst = Nothing
DoCmd.OpenReport MyReportName, acDesign
Set rpt = Reports(MyReportName)
'Ориентация
If Not IsNull(rpt.PrtDevMode) Then
strDevModeExtra = rpt.PrtDevMode
DevString.RGB = strDevModeExtra
LSet DM = DevString
DM.intOrientation = MyOrientation
LSet DevString = DM
Mid(strDevModeExtra, 1, 94) = DevString.RGB
rpt.PrtDevMode = strDevModeExtra
End If
'поля
PrtMipString.strRGB = rpt.PrtMip
LSet PM = PrtMipString
PM.lngLeftMargin = MyLeftMargin * 56.7
PM.lngRightMargin = MyRightMargin * 56.7
PM.lngToptMargin = MyTopMargin * 56.7
PM.lngBotMargin = MyBotMargin * 56.7
PM.lngColumns = MyColumns
PM.lngColumnSpacing = MyColumnSpacing * 56.7
PM.lngRowSpacing = MyRowSpacing * 56.7
PM.lngItemLayout = MyItemLayout
LSet PrtMipString = PM
rpt.PrtMip = PrtMipString.strRGB
Set rpt = Nothing
DoCmd.Close acReport, MyReportName, acSaveYes
Application.Echo True
Select Case MyMode
Case 1
DoCmd.OpenReport MyReportName, acViewPreview
DoCmd.Maximize
Case 2
DoCmd.OpenReport MyReportName
End Select
Exit Function
jsOpenReportErr:
Application.Echo True
MsgBox Err.Description
End Function
'===============================================================
Function MakeReportsPropertiesTable()
'js 14/04/2001 создание таблицы параметров отчетов
Dim MyTable As TableDef
Dim MyField As Field
Dim MyRst As Recordset
Dim MyIdx As Index
On Error Resume Next
CurrentDb.TableDefs.Delete "A_ReportsPprt"
Set MyTable = CurrentDb.CreateTableDef("A_ReportsPprt")
MyTable.Fields.Append MyTable.CreateField("ReportName", dbText, 30)
MyTable.Fields.Append MyTable.CreateField("LeftMargin", dbSingle)
MyTable.Fields.Append MyTable.CreateField("RightMargin", dbSingle)
MyTable.Fields.Append MyTable.CreateField("TopMargin", dbSingle)
MyTable.Fields.Append MyTable.CreateField("BotMargin", dbSingle)
MyTable.Fields.Append MyTable.CreateField("Columns", dbLong)
MyTable.Fields.Append MyTable.CreateField("ColumnSpacing", dbSingle)
MyTable.Fields.Append MyTable.CreateField("RowSpacing", dbSingle)
MyTable.Fields.Append MyTable.CreateField("ItemLayout", dbLong)
MyTable.Fields.Append MyTable.CreateField("Orientation", dbLong)
Set MyIdx = MyTable.CreateIndex("Primary Key")
With MyIdx
'Добавление полей в индекс
.Fields.Append .CreateField("ReportName")
.Unique = True 'Уникальный
.Primary = True 'Первичный
End With
MyTable.Indexes.Append MyIdx
CurrentDb.TableDefs.Append MyTable
End Function
Function AllReportsToPRPTable()
'js 14/04/2001 заполнение таблицы параметров
Dim PrtMipString As str_PRTMIP
Dim PM As type_PRTMIP
Dim dbs As Database, ctr As Container, doc As Document
Dim MyReportName As String
Dim MyReport As Report
Dim DevString As str_DEVMODE
Dim DM As type_DEVMODE
Dim strDevModeExtra As String
Dim MySQL As String
Call MakeReportsPropertiesTable
Set dbs = CurrentDb
Set ctr = dbs.Containers!Reports
For Each doc In ctr.Documents
MyReportName = doc.Name
DoCmd.OpenReport MyReportName, acViewPreview
Set MyReport = Reports(MyReportName)
PrtMipString.strRGB = MyReport.PrtMip
LSet PM = PrtMipString
strDevModeExtra = MyReport.PrtDevMode
DevString.RGB = strDevModeExtra
LSet DM = DevString
'в милиметрах
MySQL = "INSERT INTO A_ReportsPprt" & _
" ([ReportName], " & _
"[LeftMargin], " & _
"[RightMargin], " & _
"[TopMargin], " & _
"[BotMargin], " & _
"[Columns], " & _
"[ColumnSpacing], " & _
"[RowSpacing], " & _
"[ItemLayout], " & _
"[Orientation])" & _
" VALUES ('" & MyReportName & _
"', '" & 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 & ")"
DoCmd.SetWarnings False
CurrentDb.Execute MySQL
DoCmd.Close acReport, MyReportName, acSaveYes
Next doc
Set dbs = Nothing
End Function
Sub test()
Call jsOpenReport("R_Lables_02", 3)
End Sub
'===============================================================
Function OpenPreview()
'Обычно выполняется при открытии отчета на просмотр
'Распахивает окно (Preview отчета) вовесь экран
Dim frm As Form
DoCmd.Maximize
For Each frm In Forms
frm.Visible = False
Next frm
End Function
'===============================================================
Function ClosePreview()
'Обычно выполняется при ЗАКРЫТИИ отчета после просмотра
'Восстанавивает размеры форм после просмотра отчета
Dim frm As Form
DoCmd.Restore
For Each frm In Forms
frm.Visible = True
Next frm
End Function