'这里将使用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 SQL 语法参考手册 DB2 提供了关连式资料库的查询语言SQL (Structured Query Language), 是一种非常口语化、既易学又易懂的语法。此一语言几乎是每个资料库系统都必须提供的,用以表示关连式的操作,包含了资料的定义(DDL)以及资料 的处理(DML)。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 |
|
来自: sxczcpf > 《Access技术》