Печать большого количества отчётов (с логом в текстовом файле - опционально)

ublic Function StartReport01() As Integer
'Печать большого количества отчётов (с логом в текстовом файле)
'--------------------------------------------------------------------------
Dim iCount As Integer, iCountEnd As Integer
Dim sNoFormat As String
Dim sReportName As String
Dim sReportText As String
Dim sReportPath As String

On Error GoTo StartReport_Err
    iCountEnd = 2000 ' = Total reports
    sNoFormat = "00000"
    
    'sReportName = "prova" ' this is a simple report with only one fix text
    sReportName = "rptTest"
    
    'sReportPath = "C:\log.txt"
    sReportPath = "D:\Temp\Temp001.txt"

      
    If Dir(sReportPath, vbNormal) <> "" Then Kill sReportPath 'If file already present
    
    Open sReportPath For Append As #1 ' this is a log file
    
    For iCount = 1 To iCountEnd
        Application.DoCmd.OpenReport sReportName, acNormal
        Print #1, Format(iCount, sNoFormat); " - "; sReportName
    Next iCount

    MsgBox "Done!", vbInformation, "Printing Report " & sReportName

StartReport_End:
    On Error Resume Next
    Close #1
    Exit Function

StartReport_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: StartReport in module: 00ModuleForTests", vbCritical, "Error in Application"
    Err.Clear
    Resume StartReport_End
End Function

Public Function StartReport02()
'Печать большого количества отчётов (с логом в текстовом файле)
'IMHO Faster way
'--------------------------------------------------------------------------
Dim iCount As Integer, iCountEnd As Integer
Dim sNoFormat As String
Dim sReportName As String
Dim sReportText As String
Dim sReportPath As String
Dim iMet100%, x%, iMetAll%   'for PG all as Integer
Dim sFilter$ 'as String
On Error GoTo StartReport_Err
    iCountEnd = 2000 '= Total reports
    sNoFormat = "00000"
    
    'sReportName = "prova" ' this is a simple report with only one fix text
    sReportName = "rptTest"
    
    'sReportPath = "C:\log.txt"
    sReportPath = "D:\Temp\Temp001.txt"

'Info in status bar:
    If iCountEnd > 100 Then iMet100 = iCountEnd \ 100 Else iMet100 = 1
    SysCmd acSysCmdClearStatus 'clear status bar
    SysCmd acSysCmdInitMeter, "Printing Report " & sReportName & " ...", 100 '
       
    If Dir(sReportPath, vbNormal) <> "" Then Kill sReportPath 'If file already present
    
    DoCmd.OpenReport sReportName, acViewPreview , , acHidden
        
    Open sReportPath For Append As #1 ' this is a log file
    
    For iCount = 1 To iCountEnd
       
        sFilter = "RecID = " & iCount 'Filter by RecodID for example
        '
        Reports(sReportName).Filter = sFilter
        Reports(sReportName).FilterOn = True
        'Debug.Print "Filter: " & sFilter, vbInformation, "Printing Report " & sReportName
        DoCmd.PrintOut , , , acMedium, 1 'Print One copy by new filter
        
        Print #1, Format(iCount, sNoFormat); " - "; sReportName 'record to TXT file
        
        'Info in status bar:
        x = iCount \ iMet100
        If x > iMetAll Then
            iMetAll = x
            'Debug.Print iMetAll & "%"
            SysCmd acSysCmdUpdateMeter, iMetAll 'Show progress in status bar
        End If
    Next iCount
    
    Reports(sReportName).Filter = ""
    Reports(sReportName).FilterOn = False
    DoCmd.Close acReport, sReportName 'Close report
    MsgBox "Done!", vbInformation, "Printing Report " & sReportName
'Info in status bar:
    SysCmd acSysCmdClearStatus 'clear status bar

StartReport_End:
    On Error Resume Next
    Close #1
    Exit Function

StartReport_Err:
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: StartReport in module: 00ModuleForTests", vbCritical, "Error in Application"
    Err.Clear
    Resume StartReport_End
End Function