ACCESS VBA编程（七）ACCESS报表

竹笛

如果返回true,则报表是打开，false则报表没有打开。
Sub fCheckReport(strReport As String) As Boolean
     Dim rpt As Report
     fCheckReport=False
     For Each rpt In Reports
         If rpt.Name=strReportName Then fCheckReport=True
     Next rpt
End Function
打印当前窗体上的记录的报表
DoCmd.OpenReport "rptName", acViewNormal, , "[UniqueFieldOnReport]=Forms![frmName]![UniqueFieldOnReport]"  

全部范围内,从第二张打到第五张,高品质打印,印三份
DoCmd.PrintOut acPrintAll, 2, 5, acHigh, 3, False

生成间隔背景颜色的报表
要求:生成间隔背景颜色的报表，奇数行的背景颜色为兰色,偶数行的背景颜色为白色,兰白相间,方便查看.
方法:根据行号进行判定,设定背景色.
1 设计报表INVOICE ,必须有行号字段NO(由1开始连续的系列号)
2 设计宏SETINVOICECOLOR,条件及操作如下
条件    ([Reports]![INVOICE]![NO]) Mod 2=1
操作    Setvalue
          项目 [Reports]![INVOICE].[Section](0).[BackColor]
          表达式1632256
条件    ([Reports]![INVOICE]![NO]) Mod 2=0
操作    Setvalue
          项目 [Reports]![INVOICE].[Section](0).[BackColor]
          表达式16777215
3 设计报表INVOICE ,选定节Detail的属性中,事件"打印"为宏 SETINVOICECOLOR.
4 打印报表INVOICE,生成间隔背景颜色的报表.

报表奇偶页不同颜色显示
Option Compare Database
Option Explicit
Dim i As Integer
Private Sub 主体_Format(Cancel As Integer, FormatCount As Integer)
     i = i + 1
     If i Mod 2 = 0 Then
         Me.主体.BackColor = 12632256
     Else
         Me.主体.BackColor = 16777215
     End If
End Sub

如何在报表中产生递增的顺序编号
在报表的细节上放一个文本框，控件源等于=1 并设"运行总和"属性设置为“工作组之上”即可。

给输出的报表加个边框
Private Sub Report_Page()
Line (0, 0)-(ScaleWidth, ScaleHeight), , B
End Sub

报表页小计
在报表的主体节复制、粘贴一个要统计的数据的文本框TEXT1，属性的数据----运行总和为“全部之上”，可见性可设为“否”；
在页脚建一未绑定文本框TEXT2，用来显示页合计数据值；
        在报表的页脚的打印事件中写：
Dim x As Single
Me.TEXT2 = TEXT1 - x
x = TEXT1
实际上是每个记录的工资累计。每页结束后把这个值赋给X，下页再合计后减去X就是本页合计，以此类推。

每页固定打印7行，数据不足时用空行补齐。
最好还是用Line语句。在报表的“打印页前”事件中输入下面内容。
Private Sub Report_Page()
Dim rpt As Report, lngColor As Long
Dim i As Integer
Set rpt = Reports!当前报表
rpt.ScaleMode = 7
lngColor = RGB(255, 0, 0)
rpt.Line (2.503, 2.5)-(4.735, 6.588), lngColor, B
rpt.Line (7.354, 2.5)-(9.074, 6.588), lngColor, B
rpt.Line (10.317, 2.5)-(12.037, 6.588), lngColor, B
rpt.Line (13.81, 2.5)-(15.952, 6.588), lngColor, B
rpt.Line (19.123, 2.5)-(19.123, 6.588), lngColor
For i = 1 To 7
     rpt.Line (0.4, 2.5 + (i - 1) * 0.584)-(19.123, 2.5 + i * 0.584), lngColor, B
Next i
End Sub
应用筛选打印报表以及取消后
Sub 打印发货单_Click()
' 这段代码由“命令按钮向导”创建。
On Error GoTo Err_PrintInvoice_Click
            Dim strDocName As String
     
     strDocName = "发货单"
     ' 打印“发货单”报表，使用“发货单筛选”查询打印当前订单的发货单。
    DoCmd.OpenReport strDocName, acViewNormal, "发货单筛选"
Exit_PrintInvoice_Click:
     Exit Sub
        Err_PrintInvoice_Click:
     ' 如果用户取消操作，不显示错误消息。
    Const conErrDoCmdCancelled = 2501
     If (Err = conErrDoCmdCancelled) Then
         Resume Exit_PrintInvoice_Click
     Else
         MsgBox Err.Description
         Resume Exit_PrintInvoice_Click
     End If
        End Sub

报表打印如何用代码设定页面
Dim qdf As QueryDef
    Dim ctlLabel As Control, ctlText As Control
    Dim intDataX As Integer, intDataY As Integer
    Dim intLabelX As Integer, intLabelY As Integer
    Dim ncnt As Integer
    Dim i As Integer
    Dim ttlwidth As Double
    Dim rptWaste As Report
    Me.Painting = False
    On Error Resume Next
    Dim Dbs As Database, ctr As Container, doc As Document
    Set Dbs = CurrentDb
    ncnt = 0
     
     
    Set rptWaste = CreateReport
        Dbs.QueryDefs.Delete "www"
     Set qdf = Dbs.CreateQueryDef("www", sql)
    Dbs.QueryDefs.refresh
    ttlwidth = 30
    rptWaste.Section(acPageHeader).Height = 800
    For i = 1 To 30 - 1
            If Not (IsNull(adata(i)) or Trim(adata(i)) = "") Then
               Set ctlText = CreateReportControl(rptWaste.name, acTextBox, , "", "", intDataX, intDataY)
               Set ctlLabel = CreateReportControl(rptWaste.name, acLabel, acPageHeader, , "NewLabel", intLabelX, intLabelY)
               ctlLabel.Caption = adata(i)
               
               ctlText.Width = 1000
               If adata(i) = "card_no" Then
                    ctlText.Width = 1200
                    ctlLabel.Caption = "卡号"
               End If
               If adata(i) = "date" Then
                     ctlText.Width = 1300
                    ctlLabel.Caption = "日期"
               End If
               If adata(i) = "op_name" Then
                    ctlText.Width = 1300
                    ctlLabel.Caption = "工序号"
               End If
               If adata(i) = "class_name" Then
                    ctlText.Width = 1300
                    ctlLabel.Caption = "产品类型"
               End If
            If adata(i) = "dept_code" Then
                    ctlText.Width = 1000
                    ctlLabel.Caption = "车间代码"                  
                End If
               If adata(i) = "totalwaste_qty" Then
                    ctlText.Width = 1000
                    ctlLabel.Caption = "废品总重"
               End If
      '  End If
        ctlLabel.Width = ctlText.Width
        ctlText.ControlSource = adata(i)
        ctlText.BorderStyle = 1
        ctlLabel.BorderStyle = 1
        ctlText.Left = ttlwidth
        ctlLabel.Left = ttlwidth
        ctlLabel.Top = 800 - ctlLabel.Height
        ctlLabel.FontBold = True
        ttlwidth = ttlwidth + ctlText.Width
        End If
    Next i
    rptWaste.RecordSource = "www"
    rptWaste.Section(acDetail).Height = ctlText.Height
    Set ctlLabel = CreateReportControl(rptWaste.name, acLabel, acPageHeader, , "NewLabel", intLabelX, intLabelY)
  
    ctlLabel.Top = 0
    ctlLabel.Caption = Trim(txtDepartment.value) & "废品统计报表"
    ctlLabel.TextAlign = 2
    ctlLabel.FontSize = 16
    ctlLabel.FontBold = True
    ctlLabel.Width = 4000
    ctlLabel.Height = 500
    ctlLabel.Left = (rptWaste.Width - ctlLabel.Width) / 2
     
    Const DM_PORTRAIT = 1
    Const DM_LANDSCAPE = 2
    Dim DevString As str_DEVMODE
    Dim DM As type_DEVMODE
    Dim strDevModeExtra As String
    If Not IsNull(rptWaste.PrtDevMode) Then
        strDevModeExtra = rptWaste.PrtDevMode
        DevString.RGB = strDevModeExtra
        LSet DM = DevString
        DM.lngFields = DM.lngFields or DM.intOrientation    ' Initialize fields.
        'If DM.intOrientation = DM_PORTRAIT Then
            DM.intOrientation = DM_LANDSCAPE
        'Else
        '    DM.intOrientation = DM_PORTRAIT
        'End If
        LSet DevString = DM                     ' Update property.
        Mid(strDevModeExtra, 1, 94) = DevString.RGB
        rptWaste.PrtDevMode = strDevModeExtra
    End If
     
     
    DoCmd.DeleteObject acReport, "rptwaste_tmp"
    DoCmd.Save , "rptwaste_tmp"
    DoCmd.Close acReport, "rptwaste_tmp", acSaveNo
  '  For i = 0 To FORMs.Count - 1
  '      FORMs(i).Visible = False
  '  Next
    DoCmd.OpenReport "rptwaste_tmp", acViewPreview
        Me.Painting = True

报表中使用自定义纸张,及设置自定义纸张大小
正    文：
Private Type str_DEVMODE
     RGB As String * 94
End Type
        Private Type type_DEVMODE
     strDeviceName As String * 32
     intSpecVersion As Integer
     intDriverVersion As Integer
     intSize As Integer
     intDriverExtra As Integer
     lngFields As Long
     intOrientation As Integer
     intPaperSize As Integer
     intPaperLength As Integer
     intPaperWidth As Integer
     intScale As Integer
     intCopies As Integer
     intDefaultSource As Integer
     intPrintQuality As Integer
     intColor As Integer
     intDuplex As Integer
     intResolution As Integer
     intTTOption As Integer
     intCollate As Integer
     strFormName As String * 32
     lngPad As Long
     lngBits As Long
     lngPW As Long
     lngPH As Long
     lngDFI As Long
     lngDFr As Long
End Type
        ' rptName: 为报表名称
Public Sub CheckCustomPage(ByVal rptName As String)
            Dim DevString As str_DEVMODE
     Dim DM As type_DEVMODE
     Dim strDevModeExtra As String
     Dim rpt As Report
     Dim intResponse As Integer
     
     ' 在设计视图下打开报表
    DoCmd.OpenReport rptName, acDesign
     Set rpt = Reports(rptName)
     
     If Not IsNull(rpt.PrtDevMode) Then
         strDevModeExtra = rpt.PrtDevMode
         
         ' 获取当前的 DEVMODE 结构
        DevString.RGB = strDevModeExtra
         LSet DM = DevString
         If DM.intPaperSize = 256 Then
         
             ' 显示用户自定义纸张的尺寸
            intResponse = MsgBox("当前的自定义纸张为(mm)：" & _
                           DM.intPaperWidth / 10 & " 宽 X " & _
                           DM.intPaperLength / 10 & " 长。 你想改变吗？", _
                           vbYesNo + vbQuestion)
         Else

              ' 非自定义纸张
            intResponse = MsgBox("报表没有使用自定义纸张。 " & _
                           "你想使用自定义纸张吗?", vbYesNo + vbQuestion)
         End If
         
         If intResponse = vbYes Then
             ' 用户要改变纸张设置，初始化 DM 的各个域
            DM.lngFields = DM.lngFields or DM.intPaperSize or _
                            DM.intPaperLength or DM.intPaperWidth
                 
             ' 设置为自定义纸张
            DM.intPaperSize = 256
            
             ' 提示输入长度和宽度
            DM.intPaperLength = InputBox("请输入纸张的长度(mm)：") * 10
             DM.intPaperWidth = InputBox("请输入纸张的宽度(mm)：") * 10
            
             ' 更新属性值
            LSet DevString = DM
             Mid(strDevModeExtra, 1, 94) = DevString.RGB
             rpt.PrtDevMode = strDevModeExtra
         End If
     End If   
      Set rpt = Nothing
     
End Sub