ACCESS VBA编程（七）ACCESS报表

来源:www.accessoft.com 点击数:16536 　 | 收藏 | 复制

时　间:2013-01-22 09:18:19
作　者:周芳 ID：24526 城市：上海
摘　要:如果您想判断一个数据库中的报表是否打开，您需要检查报表连接，如下函数可以做到。
正　文:

如果返回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