Microsoft Access: Applications and Utilities

Provided by Allen Browne.

Code for Printer Selection Utility

The code in this article is explained in the Printer Selection Utility.

'Author: Allen J Browne, 2004.
'Versions: Access 2002 or later. (Uses Printer object.)

'Limitations:   1. May not work where multiple reports sent directly to print, without pause.
'               2. Reports must be opened using the OpenTheReport() function,
'                  so the printer is set *before* the report is opened.
'Methodology:   Creates a custom property of the report document.
'               The specified printer is therefore retained even if the report is renamed or copied.
'Explanation of this utility at: http://allenbrowne.com/AppPrintMgt.html

Option Compare Database
Option Explicit

Private Const mstrcPropName = "Printer2Use" 'Name of custom property assigned to the report document.
Private Const conMod = "basPrinter"         'Name of this module. Used by error handler.

'Use this function as a replacement for OpenReport.
Function OpenTheReport(strDoc As String, _
    Optional lngView As AcView = acViewPreview, _
    Optional strWhere As String, _
    Optional strDescrip As String, _
    Optional lngWindowMode As AcWindowMode = acWindowNormal) As Boolean
On Error GoTo Err_Handler
    'Purpose:   Wrapper for opening reports.
    'Arguments: View = acViewPreview or acViewNormal. Defaults to preview.
    '           strWhere = WhereCondition. Passed to OpenReport.
    '           strDescrip = description of WhereCondition (passed as OpenArgs).
    '           WindowMode = acWindowNormal or acDialog. Defaults to normal.
    'Return:    True if opened.
    'Notes:     1. Filter propery of OpenReport is not supported.
    '           2. Suppresses error 2501 if report cancelled.
    Dim bCancel As Boolean
    Dim strErrMsg As String

    'If the report is alreay open, close it so filtering is handled correctly.
    If CurrentProject.AllReports(strDoc).IsLoaded Then
        DoCmd.Close acReport, strDoc, acSaveNo
    End If

    'Set the printer for this report (if custom property defined).
    strErrMsg = vbNullString
    Call SetupPrinter4Report(strDoc, strErrMsg)
    If Len(strErrMsg) > 0 Then
        strErrMsg = strErrMsg & vbCrLf & "Continue anyway?"
        If MsgBox(strErrMsg, vbYesNo + vbDefaultButton2, "Warning") <> vbYes Then
            bCancel = True
        End If
    End If

    'Open the report
    If Not bCancel Then
        DoCmd.OpenReport strDoc, lngView, , strWhere, lngWindowMode, strDescrip
        OpenTheReport = True
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2501& 'Cancelled.
        'do nothing
    Case 2467& 'Bad report name.
        MsgBox "No report named: " & strDoc, vbExclamation, "Cannot open report."
    Case Else
        Call LogError(Err.Number, Err.Description, conMod & ".OpenTheReport")
    End Select
    Resume Exit_Handler
End Function

Public Function SetupPrinter4Report(Optional strDoc As String, Optional strErrMsg As String) As String
On Error GoTo Err_Handler
    'Purpose:   Set the application printer to the one specified for the report.
    'Argument:  Name of the report to prepare for. Omit to restore default printer.
    '           strErrMsg = message string to append problems to.
    'Return:    Name of the printer assigned, if successful.
    'Usage:     In On Activate property of report:
    '               =SetupPrinter4Report([Report].[Name])
    '           In On Deactivate and On Close properties of report:
    '               =SetupPrinter4Report()
    Dim strPrinterName As String

    If Len(strDoc) > 0 Then
        strPrinterName = GetPrinter4Report(strDoc, strErrMsg)
    End If
    'Passing zero-length string restores default printer.
    If UsePrinter(strPrinterName, strErrMsg) Then
        SetupPrinter4Report = strPrinterName
    End If

Exit_Handler:
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".SetupPrinter4Report")
    Resume Exit_Handler
End Function

Public Function AssignReportPrinter(strDoc As String, strPrinterName As String) As Boolean
On Error GoTo Err_Handler
    'Purpose:   Set or remove a custom property for the report for a particular printer.
    'Arguments: strDoc = name or report.
    '           strPrinterName = name of printer. Zero-length string to remove property.
    'Return:    True on success.
    Dim db As DAO.Database
    Dim doc As DAO.Document
    Dim strMsg As String     'Error message.
    Dim bReturn As Boolean

    'Get a reference to the report document.
    Set db = CurrentDb()
    Set doc = db.Containers("Reports").Documents(strDoc)

    If Len(strPrinterName) = 0 Then
        'Remove the property (if it exists).
        If HasProperty(doc, mstrcPropName) Then
            doc.Properties.Delete mstrcPropName
        End If
        bReturn = True
    Else
        'Create or set the property.
        If SetPropertyDAO(doc, mstrcPropName, dbText, strPrinterName, strMsg) Then
            bReturn = True
        Else
            MsgBox strMsg, vbInformation, "Printer not set for report: " & strDoc
        End If
    End If

    AssignReportPrinter = bReturn

Exit_Handler:
    Set doc = Nothing
    Set db = Nothing
    Exit Function

Err_Handler:
    Call LogError(Err.Number, Err.Description, conMod & ".AssignReportPrinter")
    Resume Exit_Handler
End Function

Public Function OpenFormSetPrinter()
On Error GoTo Err_Handler
    'Purpose:   Open the form for setting the printer of the report on screen.
    'Usage:     Called from macMenu.SetPrinter.
    Dim strReport As String

    strReport = Screen.ActiveReport.Name    'Fails if no report active.
    DoCmd.OpenForm "frmSetPrinter", WindowMode:=acDialog, OpenArgs:=strReport

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 2501&  'OpenForm was cancelled.
        'do nothing
    Case 2476&
        MsgBox "You must have a report active on screen to set a printer for it.", _
            vbExclamation, "Cannot set printer for report"
    Case Else
        Call LogError(Err.Number, Err.Description, conMod & ".OpenFormSetPrinter")
    End Select
    Resume Exit_Handler
End Function

Public Function GetPrinter4Report(strDoc As String, Optional strErrMsg As String) As String
On Error GoTo Err_Handler
    'Purpose:   Get the custom printer to use with the report.
    'Argument:  Name of the report to find the printer for.
    'Return:    Name of printer. Zero-length string if none specified, or printer no longer installed.
    Dim strPrinter As String
    Dim prn As Printer

    'Get the name of the custom printer for the report. Error if none assigned.
    strPrinter = CurrentDb().Containers("Reports").Documents(strDoc).Properties(mstrcPropName)

    If Len(strPrinter) > 0 Then
        'Check that this printer still exists. Error if printer no longer exists.
        Set prn = Application.Printers(strPrinter)
        'Return the printer name.
        GetPrinter4Report = strPrinter
    End If

Exit_Handler:
    Set prn = Nothing
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 3270&  'Property not found.
        'do nothing: means use the default printer.
    Case 5&     'No such printer.
        strErrMsg = strErrMsg & "Custom printer not found: " & strPrinter & vbCrLf & _
            "Default printer will be used." & vbCrLf
    Case Else
        Call LogError(Err.Number, Err.Description, conMod & ".GetPrinter4Report")
    End Select
    Resume Exit_Handler
End Function

Public Function UsePrinter(strPrinter As String, strErrMsg As String) As Boolean
On Error GoTo Err_Handler
    'Purpose:   Make the named printer the active one.
    'Arguments: Name of printer to assign. If zero-length string, restore default.
    '           Error message string to append to.
    'Return:    True if set (or already set).

    'If no printer specified, restore the default (by unsetting).
    If Len(strPrinter) = 0 Then
        Set Application.Printer = Nothing
    Else
        'Do nothing if printer is already set.
        If Application.Printer.DeviceName = strPrinter Then
            'do nothing
        Else
            Set Application.Printer = Application.Printers(strPrinter)
        End If
    End If
    UsePrinter = True

Exit_Handler:
    Exit Function

Err_Handler:
    Select Case Err.Number
    Case 5  'Invalid printer.
        strErrMsg = strErrMsg & "Invalid printer: " & strPrinter & vbCrLf
    Case Else
        Call LogError(Err.Number, Err.Description, conMod & ".UsePrinter")
    End Select
    Resume Exit_Handler
End Function

'------------------------------------------------------------------------------------------------
'You may prefer to replace this with a true error logger. See http://allenbrowne.com/ser-23a.html
Function LogError(lngErrNum As Long, strErrDescrip As String, _
        strCallingRoutine As String, Optional bShowUser As Boolean = True)
    Dim strMsg As String

    If bShowUser Then
        strMsg = "Error " & lngErrNum & " - " & strErrDescrip
        MsgBox strMsg, vbExclamation, strCallingRoutine
    End If
End Function

Function SetPropertyDAO(obj As Object, strPropertyName As String, intType As Integer, _
	varValue As Variant, Optional strErrMsg As String) As Boolean
On Error GoTo ErrHandler
    'Purpose:   Set a property for an object, creating if necessary.
    'Arguments: obj = the object whose property should be set.
    '           strPropertyName = the name of the property to set.
    '           intType = the type of property (needed for creating)
    '           varValue = the value to set this property to.
    '           strErrMsg = string to append any error message to.

    If HasProperty(obj, strPropertyName) Then
        obj.Properties(strPropertyName) = varValue
    Else
        obj.Properties.Append obj.CreateProperty(strPropertyName, intType, varValue)
    End If
    SetPropertyDAO = True

ExitHandler:
    Exit Function

ErrHandler:
    strErrMsg = strErrMsg & obj.Name & "." & strPropertyName & " not set to " & _
        varValue & ". Error " & Err.Number & " - " & Err.Description & vbCrLf
    Resume ExitHandler
End Function

Public Function HasProperty(obj As Object, strPropName As String) As Boolean
    'Purpose: Return true if the object has the property.
    Dim varDummy As Variant

    On Error Resume Next
    varDummy = obj.Properties(strPropName)
    HasProperty = (Err.Number = 0)
End Function