虞城那个小区户型好:ACCESS编程(3)

'这里将使用FOR EACH CONTROL的方法来清除控件的值

'这在控件比较多的时候非常有用。

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

    Dim ctl As Control

    Dim qdf As DAO.QueryDef 'qdf被定义为一个查询定义对象

    Dim strSQL As String

    For Each ctl In Me.Controls

        '根据ctl的控件类型来选择

        Select Case ctl.ControlType

            Case acTextBox '是文本框，要清空(注意，子窗体下面还有两个锁定的文本框不能赋值)

                If ctl.Locked = False Then ctl.Value = Null

            Case acComboBox '是组合框，也要清空

                ctl.Value = Null

            '其它类型的控件不处理

        End Select

    Next

    strSQL = "TRANSFORM Sum(存书查询.单价) AS 单价之Sum" & _

             " SELECT 存书查询.类别" & _

             " FROM 存书查询" & _

             " GROUP BY 存书查询.类别" & _

             " PIVOT Format([进书日期],'yyyy/mm')"

    '修改交叉表查询的SQL语句

    Set qdf = CurrentDb.QueryDefs("存书查询_交叉表")

    qdf.SQL = strSQL

    qdf.Close

    Set qdf = Nothing

    '显示交叉表的内容，不能直接刷新

    Me.存书查询子窗体.SourceObject = ""

    Me.存书查询子窗体.SourceObject = "查询.存书查询_交叉表"

    '刷新计数和合计显示

    Me.计数 = DCount("*", "存书查询_交叉表")

    Me.合计 = DSum("[单价]", "存书查询")

Exit_cmd清除_Click:

    Exit Sub

Err_cmd清除_Click:

    MsgBox Err.Description

    Resume Exit_cmd清除_Click

End Sub

Private Sub cmd预览报表_Click()

On Error GoTo Err_cmd预览报表_Click

    Dim stDocName, strWhere As String

    stDocName = "藏书情况报表"

    DoCmd.OpenReport stDocName, acViewPreview

Exit_cmd预览报表_Click:

    Exit Sub

Err_cmd预览报表_Click:

    MsgBox Err.Description

    Resume Exit_cmd预览报表_Click

End Sub

Private Sub Form_Open(Cancel As Integer)

'如果没有这一段代码，窗体打开时，虽然子窗体有显示，但下面的两个文本框是空的。

    '刷新计数和合计显示

    Me.计数 = DCount("*", "存书查询_交叉表")

    Me.合计 = DSum("[单价]", "存书查询")

End Sub

*在报表的打开事件中写：

Private Sub Report_Open(Cancel As Integer)

'ALEX 2003-5-27

'根据交叉表查询的实际字段数来设定报表各节可以显示的控件数。

'需要使用DAO 3.6

'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

    Dim rst As DAO.Recordset, intFieldsNum As Integer, I As Integer

    '打开查询

    Set rst = CurrentDb.OpenRecordset("SELECT * FROM [存书查询_交叉表] WHERE 1=2")

    rst.MoveLast

    rst.MoveFirst

    Debug.Print rst.RecordCount

    '记录字段总数

    intFieldsNum = rst.Fields.Count

    '由于报表仅有10个可变字段＋1个固定字段，所以，如果字段总数>11时，

    '只显示前面的11个字段，并给出提示。

    If intFieldsNum > 11 Then

        intFieldsNum = 11

        MsgBox "字段总数太多，报表仅显示前11个字段。", vbInformation + vbOKOnly, "提示"

    End If

    For I = 1 To 10

        If I <= (intFieldsNum - 1) Then

        '有对应字段，rst.Fields(I) 中 rst.Fields(0)是第一个，是“类别”字段。

            '页眉标签可见

            Section(acPageHeader).Controls("标签" & I).Caption =

rst.Fields(I).Name

            Section(acPageHeader).Controls("标签" & I).Visible = True

            '主体字段可见

            Section(acDetail).Controls("txt" & I).ControlSource =

rst.Fields(I).Name

            Section(acDetail).Controls("txt" & I).Visible = True

            '报表页脚合计可见

            Section(acFooter).Controls("txt合计" & I).ControlSource = "=SUM(NZ(["

& rst.Fields(I).Name & "],0))"

            Section(acFooter).Controls("txt合计" & I).Visible = True

        Else

        '没有对应字段

            '页眉标签不可见

            Section(acPageHeader).Controls("标签" & I).Visible = False

            '主体字段不可见

            Section(acDetail).Controls("txt" & I).ControlSource = ""

            Section(acDetail).Controls("txt" & I).Visible = False

            '报表页脚合计可见

            Section(acFooter).Controls("txt合计" & I).ControlSource = ""

            Section(acFooter).Controls("txt合计" & I).Visible = False

        End If

    Next

    rst.Close

    Set rst = Nothing

End Sub

进行多条件查询,  希望某一条件为空时显示全部

where  name1 like *temp1* and name2 like *temp2*

如何判断奇数（单数）、偶数（双数）？

dim a as string

(这里有一段给a赋值的代码）

if a mod 2=0 then

  msgbox"这是一个偶数"

esle

msgbox"这是一个奇数"

end if

计算在每个范围内的数量

本示例假设您有一个“Orders”表，且里头含有一个“Freight”字段。程序建立一个“选择”来计算运费落在某些范围内的订单数量。Partition

函数是用来确定这些范围，然后调用 SQL Count 函数来计算在每个范围内的订单数量。本示例中，Partition 函数的参数值为 start =

0，stop = 500，interval = 50。第一个范围会是 0：49，每隔 50 一个范围，依次而下直到运费为 500 为止。

SELECT DISTINCTROW Partition([freight],0, 500, 50) AS Range,Count(Orders.Freight) AS CountFROM OrdersGROUP BY Partition([freight],0,500,50);使用 Trim 函数显示字段的值，并且删除首尾的空格。

使用 Trim 函数显示“地址”字段的值，并且删除首尾的空格。

=Trim([地址])

Like函数示例：

查询条件为“Like "*" & [forms]![销售单输入]![文本26]”，当我输入60时，所有包含60的记录全部得出，诸如160、260、360等

只想要60的记录，并且当不输入任何数据时，所有记录全部得出

Like IIf([forms]![销售单输入]![文本26] Is Not Null,[forms]![销售单输入]![文本26],"*")

使用 Left 函数来得到某字符串最左边的几个字符。

Dim AnyString, MyStrAnyString = "Hello World"    ' 定义字符串。MyStr = Left(AnyString, 1)    ' 返回 "H"。MyStr = Left(AnyString, 7)    ' 返回 "Hello W"。MyStr = Left(AnyString, 20)    ' 返回 "Hello World"。

使用 Mid 语句来得到某个字符串中的几个字符。

Dim MyString, FirstWord, LastWord, MidWordsMyString = "Mid Function Demo"    建立一个字符串。FirstWord = Mid(MyString, 1, 3)    ' 返回 "Mid"。LastWord = Mid(MyString, 14, 4)    ' 返回 "Demo"。MidWords = Mid(MyString, 5)    ' 返回 "Funcion Demo"。

使用 Right 函数来返回某字符串右边算起的几个字符。

Dim AnyString, MyStrAnyString = "Hello World"    ' 定义字符串。MyStr = Right(AnyString, 1)    ' 返回 "d"。MyStr = Right(AnyString, 6)    ' 返回 " World"。MyStr = Right(AnyString, 20)    ' 返回 "Hello World"。使用 InStr 函数来查找某字符串在另一个字符串中首次出现的位置。

Dim SearchString, SearchChar, MyPosSearchString ="XXpXXpXXPXXP"    ' 被搜索的字符串。SearchChar = "P"    ' 要查找字符串 "P"。 ' 从第四个字符开始，以文本比较的方式找起。返回值为 6（小写 p）。' 小写 p 和大写 P 在文本比较下是一样的。MyPos = Instr(4, SearchString, SearchChar, 1)     ' 从第一个字符开使，以二进制比较的方式找起。返回值为 9（大写 P）。' 小写 p 和大写 P 在二进制比较下是不一样的。MyPos = Instr(1, SearchString, SearchChar, 0) ' 缺省的比对方式为二进制比较（最后一个参数可省略）。MyPos = Instr(SearchString, SearchChar)    ' 返回 9。 MyPos = Instr(1, SearchString, "W")    ' 返回 0。

使用 Space 函数来生成一个字符串，字符串的内容为空格，长度为指定的长度。

Dim MyString' 返回 10 个空格的字符串。MyString = Space(10) ' 将 10 个空格插入两个字符串中间。MyString = "Hello" & Space(10) & "World"

使用 String 函数来生成一指定长度，且只含单一字符的字符串。

Dim MyStringMyString = String(5, "*")    ' 返回 "*****"。MyString = String(5, 42)    ' 返回 "*****"。MyString = String(10, "ABC")    ' 返回 "AAAAAAAAAA"。使用 DLookup 函数

=DLookup("[联系人姓名]", "[供应商]", "[供应商ID] ="[供应商ID])

一、变量为数字

If IsNull(DLookup("[纺号]", "另一个表的名字", "[纺号] = " & 文本框的值)) Then

    Msgbox "该纺号不存在!"

End If

二、变量为字符串

If IsNull(DLookup("[纺号]", "另一个表的名字", "[纺号] = '" & 文本框的值 &"'")) Then

    Msgbox "该纺号不存在!"

End If

使用 Len 函数来得知某字符串的长度（字符数）或某变量的大小（位数）。

Type...End Type 程序区块定义一个自定义数据类型 CustomerRecord。如果该数据类型定义在对象类模块中，则必需以关键字 Private

开头（表示为私有）。若定义在常规模块中，Type 定义就可以为 Public。

Type CustomerRecord    ' 定义用户自定义的数据类型。    ID As Integer    ' 将此定义放在常规模块中。    Name As String * 10    Address As String * 30End TypeDim Customer As CustomerRecord    ' 声明变量。Dim MyInt As Integer, MyCur As CurrencyDim MyString, MyLenMyString = "Hello World"    ' 设置变量初值。MyLen = Len(MyInt)    ' 返回 2。MyLen = Len(Customer)    ' 返回 42。MyLen = Len(MyString)    ' 返回 11。MyLen = Len(MyCur)    ' 返回 8。

Round四舍五入。

Round(数值表达式，小数点右边应保留的位数)

用按钮在窗体中按指定字段查找记录

例一：

Private Sub 查找记录_Click()

On Error GoTo Err_查找记录_Click

''指定字段名称[学生编号]

    DoCmd.GoToControl "学生编号"

    DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70

Exit_查找记录_Click:

    Exit Sub

Err_查找记录_Click:

    MsgBox Err.Description

    Resume Exit_查找记录_Click

End Sub

例二

Private Sub 按毕业时间查找_Click()

On Error GoTo 按毕业时间查找_Click_Err

''在窗体中按基础表的参数筛选

    DoCmd.ApplyFilter "", "Left([学生基本情况]![学生编号],4)+6=[请输入学生毕业年份(四位数)]"

按毕业时间查找_Click_Exit:

    Exit Sub

按毕业时间查找_Click_Err:

    MsgBox Error$

    Resume 按毕业时间查找_Click_Exit

End Sub

ＳＱＬ 语法参考手册

DB2 提供了关连式资料库的查询语言ＳＱＬ (Structured Query Language)，

是一种非常口语化、既易学又易懂的语法。此一语言几乎是每个资料库系统都必须提供的，用以表示关连式的操作，包含了资料的定义（ＤＤＬ）以及资料

的处理（ＤＭＬ）。SQL原来拼成 SEQUEL，这语言的原型以“系统 R“的名 字在 IBM 圣荷西实验室完成，经过 IBM

内部及其他的许多使用性及效率测试，其结果相当令人满意，并决定在系统R 的技术基础发展出来 IBM

的产品。而且美国国家标准学会（ANSI）及国际标准化组织（ISO　在 1987 遵循一个几乎 是以 IBM SQL 为基础的标准关连式资料语言定义。

基本查询

SELECT column1,columns2,... FROM table_name

说明：把table_name 的特定栏位资料全部列出来

SELECT *

FROM table_name

WHERE column1 = xxx

[AND column2 > yyy] [OR column3 <> zzz]

说明：

1.'*'表示全部的栏位都列出来

2.WHERE 之後是接条件式，把符合条件的资料列出来

SELECT column1,column2

FROM table_name

ORDER BY column2 [DESC]

说明：

ORDER BY 是指定以某个栏位做排序，[DESC]是指从大到小排列，若

没有指明，则是从小到大排列

组合查询

组合查询是指所查询得资料来源并不只有单一的表格，而是联合一个以上的表格才能够得到结果的。

SELECT *

FROM table1,table2

WHERE table1.colum1=table2.column1

说明：

1.查询两个表格中其中 column1 值相同的资料

2.当然两个表格相互比较的栏位，其资料形态必须相同

3.一个复杂的查询其动用到的表格可能会很多个

整合性的查询：

SELECT COUNT (*)

FROM table_name

WHERE column_name = xxx

说明：

查询符合条件的资料共有几笔

SELECT SUM(column1)

FROM table_name

说明：

1.计算出总和，所选的栏位必须是可数的数字形态

2.除此以外还有 AVG() 是计算平均、MAX()、MIN()

计算最大最小值的整合性查询

SELECT column1,AVG(column2)

FROM table_name

GROUP BY column1

HAVING AVG(column2) > xxx

说明：

1.GROUP BY: 以column1 为一组计算 column2 的平均值

必须和 AVG、SUM 等整合性查询的关键字一起使用

2.HAVING : 必须和 GROUP BY 一起使用作为整合性的限制

复合性的查询

SELECT *

FROM table_name1

WHERE EXISTS (

SELECT *

FROM table_name2

WHERE conditions )

说明：

1.WHERE 的 conditions 可以是另外一个的 query

2.EXISTS 在此是指存在与否

SELECT *

FROM table_name1

WHERE column1 IN (

SELECT column1

FROM table_name2

WHERE conditions )

说明　

1. IN 後面接的是一个集合，表示column1 存在集合里面

2. SELECT 出来的资料形态必须符合 column1

其他查询

SELECT *

FROM table_name1

WHERE column1 LIKE 'x%'

说明：

LIKE 必须和後面的'x%' 相呼应表示以 x为开头的字串

SELECT *

FROM table_name1

WHERE column1 IN ('xxx','yyy',..)

说明　

IN 後面接的是一个集合，表示column1 存在集合里面

SELECT *

FROM table_name1

WHERE column1 BETWEEN xx AND yy

说明　

BETWEEN 表示 column1 的值介於 xx 和 yy 之间

更改资料：

UPDATE table_name

SET column1='xxx'

WHERE conditoins

说明：

1.更改某个栏位设定其值为'xxx'

2.conditions 是所要符合的条件、若没有 WHERE 则

整个 table 的那个栏位都会全部被更改

删除资料：

DELETE FROM table_name

WHERE conditions

说明：删除符合条件的资料

报表

如果您想判断一个数据库中的报表是否打开，您需要检查报表连接，如下函数可以做到。

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

Vba技巧:

显示窗体“第n条记录 共m条记录”的函数

调用方法：

=RecordNumber("第",me)'me指当前窗体

可在文框的控件来源中写：=RecordNumber("第",forms!当前窗体名)

在代码的窗体成为当前事件中写：me.文本框=RecordNumber("第", Me)

结果虽相同，但在代码中的要快！

但是，在代码的窗体成为当前事件中写：Me.标签.Caption = RecordNumber("第", Me)

用标签，速度明显要比前两个用法还要快！

Function RecordNumber(pstrPreFix As String, pfrm As Form) As String

On Error GoTo RecordNumber_Err

Dim rst

Dim lngNumRecords As Long

Dim lngCurrentRecord As Long

Dim strTmp As String

Set rst = pfrm.RecordsetClone

rst.MoveLast

rst.Bookmark = pfrm.Bookmark

lngNumRecords = rst.RecordCount

lngCurrentRecord = rst.AbsolutePosition + 1

strTmp = pstrPreFix & " " & lngCurrentRecord & " 页，" & " 共 " & lngNumRecords & "

" & "页"

RecordNumber_Exit:

On Error Resume Next

RecordNumber = strTmp

rst.Close

Set rst = Nothing

Exit Function

RecordNumber_Err:

Select Case Err

Case 3021

strTmp = "New Record"

Resume RecordNumber_Exit

Case Else

strTmp = "#" & Error

Resume RecordNumber_Exit

End Select

End Function

获取ACCESS错误号与对应的中文解释

Sub MMM()

For e = 1 To 100

  Debug.Print e; " - "; Error(e)

Next

End Sub

执行上述代码将显示如下结果：

 1  - 应用程序定义或对象定义错误

 2  - 应用程序定义或对象定义错误

 3  - 无 GoSub 返回

 4  - 应用程序定义或对象定义错误

 5  - 无效的过程调用或参数

 6  - 溢出

 7  - 内存溢出

对话框返回文本框内容

InputBox(prompt[, title] [, default] [, xpos] [, ypos] [, helpfile, context])

InputBox 函数的语法具有以下几个命名参数：

Prompt：必需的。作为对话框消息出现的字符串表达式。prompt 的最大长度大约是 1024 个字符，由所用字符的宽度决定。如果 prompt

包含多个行，则可在各行之间用回车符 (Chr(13))、换行符 (Chr(10)) 或回车换行符的组合 (Chr(13) & Chr(10)) 来分隔。

Title：可选的。显示对话框标题栏中的字符串表达式。如果省略 title，则把应用程序名放入标题栏中。

Default：可选的。显示文本框中的字符串表达式，在没有其它输入时作为缺省值。如果省略 default，则文本框为空。

Xpos：可选的。数值表达式，成对出现，指定对话框的左边与屏幕左边的水平距离。如果省略 xpos，则对话框会在水平方向居中。

Ypos：可选的。数值表达式，成对出现，指定对话框的上边与屏幕上边的距离。如果省略 ypos，则对话框被放置在屏幕垂直方向距下边大约三分之一的位置。

Helpfile：可选的。字符串表达式，识别帮助文件，用该文件为对话框提供上下文相关的帮助。如果已提供 helpfile，则也必须提供 context。

Context: 可选的。数值表达式，由帮助文件的作者指定给某个帮助主题的帮助上下文编号。如果已提供 context，则也必须要提供 helpfile。

示例：

本示例说明使用 InputBox 函数来显示用户输入数据的不同用法。如果省略 x 及 y

坐标值，则会自动将对话框放置在两个坐标的正中。如果用户单击“确定”按钮或按下“ENTER”按键，则变量 MyValue

保存用户输入的数据。如果用户单击“取消”按钮，则返回一零长度字符串。

Dim Message, Title, Default, MyValueMessage = "Enter a value between 1 and 3"    ' 设置提示信息。Title = "InputBox Demo"    ' 设置标题。Default = "1"    ' 设置缺省值。' 显示信息、标题及缺省值。MyValue = InputBox(Message, Title, Default) ' 使用帮助文件及上下文。“帮助”按钮便会自动出现。MyValue = InputBox(Message, Title, , , , "DEMO.HLP", 10) ' 在 100, 100 的位置显示对话框。MyValue = InputBox(Message, Title, Default, 100, 100)

根据屏幕分辨率自动调整窗体大小：

Option Compare Database

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As

Long

Private Const SM_CXSCREEN = 0

Private Const SM_CYSCREEN = 1

Private Sub Form_Open(Cancel As Integer)

Dim x As Long, y As Long, a As Long, b As Long

x = GetSystemMetrics(SM_CXSCREEN)

y = GetSystemMetrics(SM_CYSCREEN)

a = 10000 / 800 * x

b = 7000 / 600 * y

DoCmd.MoveSize 1134, 1134, a, b

End Sub

获得系统的屏幕区域大小

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As

Long

Private Const SM_CXSCREEN = 0

Private Const SM_CYSCREEN = 1

Private Sub Command0_Click()

Dim x As Long, y As Long

x = GetSystemMetrics(SM_CXSCREEN)

y = GetSystemMetrics(SM_CYSCREEN)

MsgBox x & "  " & y

End Sub

让控件自适应屏幕分辨率2

来源：ACCESS爱好者

'这个函数可以使你开发的程序适应各种分辨率，这是我见过的最完美的解决方案！强列推荐

''如果你是在1024*768的分辨率下写的程序，就把下面那句改为

Const DesignSize = 1024，如果是800*600分

'辨率下写的，就改为Const DesignSize = 800

'用法：把下面所有的代码放在一个模块里，在需要适应分辨率的窗体的Load事

'件里加入Call FormResiz_OnOpen(Me)

'

'Const DesignSize = 1024

Const DesignSize = 800

'☆★☆★☆★☆★☆★☆★☆★☆★☆★

'API宣言

Declare Function GetDesktopWindow Lib "User32" () As Long

Declare Function GetWindowRect Lib "User32" (ByVal hWnd As Long, rectangle As

RECT) As Long

'Type宣言

Type RECT

x1 As Long

y1 As Long

x2 As Long

y2 As Long

End Type

'国标码宣言

Dim frm As Form

Dim ctrl As Control

Dim prp As Property

Dim rat As Double

Dim flgSec

Dim X As Long

Dim WinHeight As Long

Dim hWnd As Long

Dim ret As Long

Dim i As Integer

Dim R As RECT

Dim SizeL As Long

Dim SizeT As Long

Dim SizeW As Long

Dim SizeH As Long

'--------------------------------------------------------------------------------

Public Function FormResiz_OnOpen(parFrm As Form, Optional perSizeL As Long,

Optional perSizeT As Long, Optional perSizeW As Long, Optional perSizeH As Long)

On Error Resume Next

Set frm = parFrm

'窗口驾驶盘的取得

hWnd = GetDesktopWindow()

'现在分辨率取得

ret = GetWindowRect(hWnd, R)

'比例计算 常例：现在800 开发1024 800/1024 = 0.78加倍

X = (R.x2 - R.x1)

rat = X / DesignSize

SizeL = 0: SizeT = 0: SizeW = 0: SizeH = 0

If Not IsEmpty(perSizeL) = True Then

SizeL = perSizeL * rat

SizeT = perSizeT * rat

SizeW = perSizeW * rat

SizeH = perSizeH * rat

End If

'现在分辨率＝开发分辨率如果终了

If X = DesignSize Then Exit Function

If X < DesignSize Then

'细小策划时、控制＞部分＞表单的次序

Call ChangeCtrl

Call ChengeSec

Call ChangeFrm

Else

'大掬取时、表单＞部分＞控制的次序

Call ChangeFrm

Call ChengeSec

Call ChangeCtrl

End If

'最后、表单的使清新

frm.Refresh

Exit Function

End Function

'--------------------------------------------------------------------------------

Private Sub ChangeCtrl()

On Error Resume Next

'控制转

For Each ctrl In frm.Controls

'*******************************************************************

'选项卡修正，原著没有这段代码，后来有个朋友发现了这个BUG，就是选项卡的位置会偏得很厉害

'所以就加了这段代码来修正

'主要是"Top", "Height","Left","Width"这几个参数的值，根据实际情况适当调整就行了

If ctrl.ControlType = 123 Or ctrl.ControlType = 124 Then

For Each prp In ctrl.Properties

Select Case prp.Name

Case "FontSize", "DatasheetFontHeight"

prp.value = Fix(prp.value * rat + 0.5)

Case "FontWeight"

prp.value = Fix((prp.value * rat) / 100) * 100

Case "Top", "Height"

prp.value = Fix(prp.value * rat * 0.85)

'prp.value = Fix(prp.value * rat)

Case "Left"

prp.value = Fix(prp.value * rat * 0.9)

Case "Width"

prp.value = Fix(prp.value * rat * 0.7)

End Select

Next prp

'********************************************************************************************

Else

'属性转

For Each prp In ctrl.Properties

'大小·配置关于属性被发现们压缩

Select Case prp.Name

Case "FontSize", "DatasheetFontHeight"

'通常计算假如行…情况之下的 +0.5 之类的话不需要是…但…、

'捆Zo~Ma办法。稍微心情坏因为 +0.5

prp.value = Fix(prp.value * rat + 0.5)

Case "FontWeight"

prp.value = Fix((prp.value * rat) / 100) * 100

Case "Left", "Top", "Width", "Height"

prp.value = Fix(prp.value * rat)

End Select

Next prp

End If

Next ctrl

End Sub

'--------------------------------------------------------------------------------

Private Sub ChengeSec()

On Error GoTo Err_Disp

'部分转

flgSec = True

i = 0

'不存在部分的参照错误化验出终了

Do Until flgSec = False

'部分被发现们高度变更

frm.Section(i).Height = Fix(frm.Section(i).Height * rat)

i = i + 1

Loop

Exit Sub

Err_Disp:

If Err = 2462 Then

flgSec = False

Resume Next

Else

MsgBox Err.Description

End If

Resume Next

End Sub

'--------------------------------------------------------------------------------

Private Sub ChangeFrm()

On Error Resume Next

'表单的大小变更

'Optional参数数值渡下次收拾ば、而且使合（计算正在完毕）

If SizeL > 0 Then

DoCmd.MoveSize SizeL, SizeT, SizeW, SizeH

Else

'特别是指定啊假如踢、变更了表单的大小表示

'表单的属性（宽与高度）

frm.Width = Fix(frm.Width * rat)

WinHeight = Fix(frm.WindowHeight * rat)

DoCmd.MoveSize , , frm.Width, WinHeight

End If

End Sub

用VBA赋应用程序图标

见测试窗体

Toolbar 控件使用

本例在一个Toolbar控件中添加五个 Button 对象，并且向每个 Button 对象添加二个 ButtonMenu

对象。单击ButtonMenu对象时，其行为由ButtonMenuClick事件来决定。为了试验本例，在窗体中放置一个 Toolbar

控件，将代码粘贴到代码模块的声明部分。

Option Explicit

Private Sub Toolbar1_ButtonMenuClick(ByVal ButtonMenu As ComctlLib.ButtonMenu)

   Select Case ButtonMenu.Index

   Case 1

      MsgBox "Press the button."

   Case 2

      MsgBox "Offer some option"

   End Select

End Sub

' 窗体加载事件：

Private Sub Form_Load()

   Dim i As Integer

   Dim btn As Button

   ' 添加五个 Button 对象到 Toolbar 控件。

   For i = 1 To 5

      Set btn = Toolbar1.Buttons.Add(Caption:= i, Style:= tbrDropDown)

      ' 添加两个 ButtonMenu 对象到每一个Button。

         btn.ButtonMenus.Add Text:="Help"

         btn.ButtonMenus.Add Text:="Options"

   Next i

End Sub

Treeview 控件的使用方法

建立一个窗体，在窗体上放置如下控件：

Treeview 控件：名称 Treeview1；

　　Imagelist 控件：名称 Imagelist1，并在该控件中放置三张个性图片（32×32），建立索引1、2、3；（方法：在Imagelist

控件上单击鼠标右键选择属性）

　　Label 控件：名称分别为Lab（0）、Lab（1），Caption分别为“父节点：”、“子节点：”；

　　Textbox 控件：名称分别为Txt（0）、Txt（1），text都为“”；

　　commandbutton 控件：名称为系统默认，Caption分别为“添加”、“展开”、“收起”、“排序”、“删除”、“退出”；

　　将下列代码加入到代码框：

Option Explicit

Dim I As Integer

Dim J As Integer

Dim nodx As Node

Dim CunZai As Boolean '定义变量

Private Sub Command1_Click()

　If Txt(0).Text <> "" And Txt(1).Text <> "" Then '不允许建立零字节的父节点和子节点

　　CunZai = False

　　J = TreeView1.Nodes.Count

　　For I = 1 To TreeView1.Nodes.Count '检查新输入的父节点名称是否存在

　　　If TreeView1.SelectedItem.Children > 0 Then

　　　　If Txt(0).Text = TreeView1.Nodes(I).Text Then CunZai = True

　　　　End If

　　Next I

　　If CunZai = True Then '若存在, 则在父节点下建立子节点

　　　Set nodx = TreeView1.Nodes.Add(Txt(0).Text, tvwChild, "child" & J,

　　　　　　　　　　　　　　 Txt(1).Text, 3)

　　Else ,若不存在,则建立父节点和子节点

　　　Set nodx = TreeView1.Nodes.Add(, , Txt(0).Text, Txt(0).Text, 1)

　　　Set nodx = TreeView1.Nodes.Add(Txt(0).Text, tvwChild, "child" & J,_

　　　　　　　　　　Txt(1).Text, 3)

　　End If

　　TreeView1.Refresh

　ElseIf Txt(0).Text = "" Then MsgBox "请输入父节点名称!", vbInformation, "警告！"

　 '系统提示

　ElseIf Txt(1).Text = "" Then MsgBox "请输入子节点名称!", vbInformation, "警告！"

　End If

End Sub

Private Sub Command2_Click()

　For I = 1 To TreeView1.Nodes.Count

　　TreeView1.Nodes(I).Expanded = True '展开所有节点

　Next I

End Sub

Private Sub Command3_Click()

　For I = 1 To TreeView1.Nodes.Count

　　TreeView1.Nodes(I).Expanded = False '收起所有节点

　Next I

End Sub

Private Sub Command4_Click()

　TreeView1.Sorted = True '排列顺序

End Sub

Private Sub Command5_Click()

　If TreeView1.SelectedItem.Index <> 1 Then