玩转报表打印设置-AngelHis专栏

PRT_LIST 获取打印机列表函数，
PAPER_LIST 获取指定打印机支持的纸张列表函数，
printRpt 自定义打印函数。
使用方法：创建表RPT_SETTING，储存各个报表的打印参数。使用printRpt 函数打印报表，打印时系统通过调用表RPT_SETTING储存的参数实现自由打印。

创建打印模块，创建打印函数

Option Compare Database

Option Explicit
Private Const DC_MAXEXTENT = 5
Private Const DC_MINEXTENT = 4
Private Const DC_PAPERNAMES = 16
Private Const DC_PAPERS = 2
Private Const DC_PAPERSIZE = 3
Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, lpDevMode As Any) As Long
Private Type POINTS
    X As Long
    Y As Long
End Type

Function PRT_LIST() As String   ' 获取打印机信息
    Dim strDefaultPrinter As String    ' 包含默认打印机索引的变量。
    Dim prt As Printer  ' 包含打印机对象的变量
    For Each prt In Application.Printers
        PRT_LIST = prt.DeviceName & ";" & PRT_LIST
    Next
    strDefaultPrinter = Application.Printer.DeviceName    ' 记忆默认打印机。
End Function

Function PAPER_LIST(strPrnt As String) As String     ' 获取纸张信息
    On Error Resume Next
    Dim PAPER_item As String
    Dim i As Long, ret As Long
    Dim Length As Integer, Width As Integer
    Dim PaperNo() As Integer, PaperName() As String, PaperSize() As POINTS
    '支持最大打印纸：
    ret = DeviceCapabilities(strPrnt, "LPT1", DC_MAXEXTENT, ByVal 0&, ByVal 0&)
    Length = ret \ 65536
    Width = ret - Length * 65536
    '支持最小打印纸：
    ret = DeviceCapabilities(strPrnt, "LPT1", DC_MINEXTENT, ByVal 0&, ByVal 0&)
    Length = ret \ 65536
    Width = ret - Length * 65536
    '支持纸张种类数
    ret = DeviceCapabilities(strPrnt, "LPT1", DC_PAPERS, ByVal 0&, ByVal 0&)
    '纸张编号
    ReDim PaperNo(1 To ret) As Integer
    Call DeviceCapabilities(strPrnt, "LPT1", DC_PAPERS, PaperNo(1), ByVal 0&)
    '纸张名称
    Dim arrPageName() As Byte
    Dim allNames As String
    Dim lStart As Long, lEnd As Long
    ReDim PaperName(1 To ret) As String
    ReDim arrPageName(1 To ret * 64) As Byte
    Call DeviceCapabilities(strPrnt, "LPT1", DC_PAPERNAMES, arrPageName(1), ByVal 0&)
    allNames = StrConv(arrPageName, vbUnicode)
    ' 遍历纸张的编号和名称
    i = 1
    Do
        lEnd = InStr(lStart + 1, allNames, Chr$(0), vbBinaryCompare)
        If (lEnd > 0) And (lEnd - lStart - 1 > 0) Then
            PaperName(i) = Mid$(allNames, lStart + 1, lEnd - lStart - 1)
            i = i + 1
        End If
        lStart = lEnd
    Loop Until lEnd = 0
    '纸张尺寸
    ReDim PaperSize(1 To ret) As POINTS
    Call DeviceCapabilities(strPrnt, "LPT1", DC_PAPERSIZE, PaperSize(1), ByVal 0&)
    '    "纸张编号" & ";" & "纸张名称" & ";" & "宽度" & ";" & "高度"
    For i = 1 To ret
        PAPER_item = PaperNo(i) & ";" & PaperName(i) & ";" & PaperSize(i).X / 10 & ";" & PaperSize(i).Y / 10
        '        MsgBox PAPER_item
        PAPER_LIST = PAPER_LIST & ";" & PAPER_item
    Next i
    PAPER_LIST = Mid(PAPER_LIST, 2)
End Function

Function PrintRpt(ByVal strRptName As String, conStr As String, prtView As Integer) As Integer '自定义打印函数
    On Error GoTo err
    Dim rpt As Report
    Dim strPrinter As String         ' 打印机名称
    Dim intPapersize As Integer      ' 纸张编号
    Dim intOrientation As Integer    ' 打印方向
    Dim intTop As Integer            ' 上边距(mm)
    Dim intBottom As Integer         ' 下边距(mm)
    Dim intLeft As Integer           ' 左边距(mm)
    Dim intRight As Integer          ' 右边距(mm)
    Dim prt As Printer
    ' 获取表"RPT_SETTING"中相关报表信息
    strPrinter = Nz(DLookup("[PRINT_NAME]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'"))
    strPrinter = IIf(strPrinter = "", Application.Printer.DeviceName, strPrinter)   ' 选择默认打印机
    intPapersize = Nz(DLookup("[PAPER_CODE]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'"))
    intOrientation = Nz(DLookup("[PAPER_ORI]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'"))
    intTop = Nz(DLookup("[U_DIST]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'") * 56.7)
    intBottom = Nz(DLookup("[D_DIST]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'") * 56.7)
    intLeft = Nz(DLookup("[L_DIST]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'") * 56.7)
    intRight = Nz(DLookup("[R_DIST]", "RPT_SETTING", "[REPORT_NAME]='" & strRptName & "'") * 56.7)
    DoCmd.OpenReport strRptName, acViewPreview, , conStr, acHidden   '隐式打开报表，以加载报表设置参数
    Set rpt = Reports(strRptName)    ' 将报表的页面设置为已定义好的页面设置。
    rpt.Printer = Application.Printers(strPrinter)
    rpt.Printer.PaperSize = intPapersize
    rpt.Printer.Orientation = intOrientation
    rpt.Printer.TopMargin = intTop
    rpt.Printer.BottomMargin = intBottom
    rpt.Printer.LeftMargin = intLeft
    rpt.Printer.RightMargin = intRight
    If prtView = 0 Then    '预览
        DoCmd.OpenReport strRptName, acViewPreview, , conStr
    ElseIf prtView = 1 Then    '打印
        DoCmd.OpenReport strRptName, , , conStr
        DoCmd.Close acReport, strRptName, acSaveYes
    End If
    PrintRpt = 1
    Exit Function
err:
    DoCmd.Close acReport, strRptName
    PrintRpt = 0
End Function

实例：

If MsgBox("入院登记成功，是否打印住院押金收据？", vbYesNo, "") = vbYes Then
                Dim rptname As String
                rptname = "住院押金凭证入院_收款员"
                i = PrintRpt(rptname, "OPER_DATE  = #" & OPER_DATE & "#", 1)
                If i = 0 Then
                    MsgBox "报表【" & rptname & "】参数设置有错误，请联系管理员！", vbCritical, "系统提示"
                End If
 End If

点击下载此附件