Access编程 VBA(2)

program 2007-07-20 10:30:36 阅读114 评论0   字号：大中小 订阅

 

 

'输入:

' sSvrName 数据库服务器名

' sUID 用户名

' sPWD 口令

' sDatabase MSDE数据库名

'

'输出:

' 连接状态

'

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

On Error GoTo sCreateConnectionTrap:

If Application.CurrentProject.BaseConnectionString = "" Then

'表示ADP处于无连接状态

sConnectionString = "PROVIDER=SQLOLEDB.1;PASSWORD=" & sPWD _

& ";PERSIST SECURITY INFO=TRUE;USER ID=" & sUID & "; _

INITIAL CATALOG=" & sDatabase & ";DATA SOURCE=" & sSvrName

Application.CurrentProject.OpenConnection sConnectionString

sCreateConnection = "创建了到 " & sDatabase & " 数据库的连接!"

Else '连接已存在

sCreateConnection = "已经存在到 " & sDatabase & " 数据库的连接!"

End If

 

sCreateConnectionExit:

Exit Function

sCreateConnectionTrap:

sCreateConnection = Err.Description

Resume sCreateConnectionExit

End Function

 

-------------------------------------

此例程将从 ADP 删除连接,使其处于无连接状态。

Sub MakeADPConnectionless()

Application.CurrentProject.CloseConnection '关闭连接

Application.CurrentProject.OpenConnection '将连接设置为无

End Sub

 

重新定位链接表二步走

来源：爱赛思应用俱乐部 kevindeng

尽管Accxp网上有很多关于定位链接表的贴子，但还是有很多的朋友询问这方面的问题。应letter网友的提议，结合Alex总版主的重新定位链接表文件源码，现将这方面的具体操作介绍如下：

 

假设前台数据库文件名为frontBase.mdb

后台数据库文件名为backData.mdb

frontBase当中有链接表tbl1, tbl2, tbl3, …，链接到backData.mdb中

首先我们要在前台数据库文件的启动窗体加载事件中判断链接是否正确，方法是打开任意一个链接表，假设为tbl1，代码如下：

Public Function CheckLinks() As Boolean

' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。　　

　　Dim dbs As Database, rst As DAO.Recordset　　

　　Set dbs = CurrentDb()

　　' 打开链接表查看表链接信息是否正确。

　　On Error Resume Next

　　Set rst = dbs.OpenRecordset(“tbl1”)

　　rst.Close

　　' 如果没有错误，返回 True 。

　　If Err = 0 Then

　　　　CheckLinks = True

　　Else

　　　　CheckLinks = False

　　End If　　

End Function

启动窗体的加载事件：

Private Sub FORM_Load()

If CheckLinks = False then

Docmd.OpenFORM “frmConnect”

End If

End Sub

frmConnect 连接窗体如下图

[img]f:\m.bmp[/img]

 

接下来的事情就是如何刷新链接表了。

上面的窗体右边的按钮是用用来调用API打开文件对话框，具体代码如下：

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA"

(pOpenfilename As OPENFILENAME) As Boolean

Type OPENFILENAME

　　lStructSize As Long

　　hwndOwner As Long

　　hInstance As Long

　　lpstrFilter As String

　　lpstrCustomFilter As String

　　nMaxCustFilter As Long

　　nFilterIndex As Long

　　lpstrFile As String

　　nMaxFile As Long

　　lpstrFileTitle As String

　　nMaxFileTitle As Long

　　lpstrInitialDir As String

　　lpstrTitle As String

　　flags As Long

　　nFileOffset As Integer

　　nFileExtension As Integer

　　lpstrDefExt As String

　　lCustData As Long

　　lpfnHook As Long

　　lpTemplateName As String

End Type

Private Sub FileOpen_Click()

　 Dim ofn As OPENFILENAME

　 Dim rtn As String

　 ofn.lStructSize = Len(ofn)

　 ofn.hwndOwner = Me.hwnd

　

　 ofn.lpstrFilter = "数据库文件 (*.mdb)" & vbNullChar & "*.mdb"

　 ofn.lpstrFile = Space(254)

　 ofn.nMaxFile = 255

　 ofn.lpstrFileTitle = Space(254)

　 ofn.nMaxFileTitle = 255

　 ofn.lpstrInitialDir = CurrentProject.Path

　 ofn.lpstrTitle = "后台数据文件为"

　 ofn.flags = 6148

　 rtn = GetOpenFileName(ofn)

　

　 FileName.SetFocus

　 If rtn = True Then

　　　 FileName.Text = ofn.lpstrFile

　　　 FileName.Text = FileName.Text

　　　 OK.Enabled = True

　 Else

　　　 FileName.Text = ""

　 End If

End Sub

连接按钮刷新链接表，代码如下：

Private Sub OK_Click()

Dim tabDef As TableDef

For Each tabDef In CurrentDb.TableDefs

If Len(tabDef.Connect) > 0 Then

tabDef.Connect = ";DATABASE=" & Me.FileName.Text & ";PWD=" + 后台数据库密码

tabDef.RefreshLink

End If

Next

MsgBox "连接成功！"

DoCmd.Close acFORM, Me.Name

End Sub

 

其实很简单只有两步，判断链接是否正确和刷新链接表。

 

 

数据库与照片的关系如何处理？

有照片若干，怎样能在数据库中存储并显示？

1、把照片放进数据库，照片的格式最好是bmp，这样就可以在窗体上显示出来，不过这样数据库的体积会暴增。设一个OLE字段，然后插入对象就行了（对着字段单击右键）

2、不把照片放入数据库，只把照片的路径保存到数据库中，动态加载，这样可以支持很多种图片格式。（见示例）

If Dir(Application.CurrentProject.Path & "\img\" & Me!ID & ".jpg") <> "" Then

    Me!照片.Picture = Application.CurrentProject.Path & "\img\" & Me!ID & ".jpg"

Else

    Me!照片.Picture = Application.CurrentProject.Path & "\img\0.jpg"

End If

 

 

导出成EXECL表

DoCmd.TransferSpreadsheet acExport, 8, "" & Text0 & "", "A:\" & Text0 & ".xls",

True, ""

6、如何建立简单的超级连接？

*API函数声明

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecute A"

(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal

lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd A s Long) As

Long

注释：打开某个网址

ShellExecute 0, "open", " http://tyvb.126.com";, vbNullString, vbNullString, 3

注释：给某个信箱发电子邮件

ShellExecute hwnd, "open", "mailto:[e-mail]", vbNullString, vbNullString,

0

 

ACCESS表

用ADO编程隐藏表

sub hide_table()

    Dim cnn As New ADODB.Connection

    Dim cat As New ADOX.Catalog

    Set cat.ActiveConnection = CurrentProject.Connection

    Dim tbl As ADOX.Table

    Dim pro As Property

    For Each tbl In cat.Tables

    Debug.Print tbl.name

        For Each pro In tbl.Properties

            Debug.Print pro.name & "=" & pro.value

        Next

        If tbl.name = "需要隐藏的表名" Then tbl.Properties.Item("Jet OLEDB:Table Hidden

In Access") = True

    Next

End Sub

 

如何用VBA代码更改表中字段的数据类型或加字段

使用ALTER COLUMN改变一个当前字段的数据类型，需要指定字段名、新数据类型、还可以 (对文本和二进制字段)指定长度。

改字段

alter table 你的表名 alter column 你的字段名 数据类型

例如，下列语句把雇员表中一个字段的数据类型, 被称为ZipCode（最初被定义为整数），改变成一个10字符文本字段：

CurrentDb.Execute "ALTER TABLE 地址 ALTER COLUMN sz TEXT(22)"

改为逻辑型：

CurrentDb.Execute "ALTER TABLE 地址 ALTER COLUMN sz BIT"

日期时间：

CurrentDb.Execute "ALTER TABLE 地址 ALTER COLUMN sz date"

备注型：

CurrentDb.Execute "ALTER TABLE 地址 ALTER COLUMN sz memo"

货币：

money 8 个字节 介于 – 922,337,203,685,477.5808 到 922,337,203,685,477.5807 之间的符号整数。

real 4 个字节 单精度浮点数，负数范围是从 –3.402823e38 到 –1.401298e-45，正数从1.401298e-45 到

3.402823e38，和 0。

float 8 个字节双精度浮点数，负数范围是从 –1.79769313486232e308 到 –4.94065645841247e-324，正数从

4.94065645841247e-324 到 1.79769313486232e308，和 0。

smallint 2 个字节介于 –32,768 到 32,767 的短整型数。

integer 4 个字节 介于 –2,147,483,648 到 2,147,483,647 的长整型数。

decimal 17 个字节容纳从 1028 - 1到 - 1028 - 1. 的值的精确的数字数据类型。你可以定义精度 (1 - 28) 和 符号 (0 -

定义精度)。缺省精度和符号分别是18和0

 

加字段

CurrentDb.Execute "Alter Table 地址 Add Column 字段三 Char(2)"

CurrentDb.Execute "Alter Table 地址 Add Column 字段1 BIT"

如何用sql语句添加删除主键？

来源：access911.net

Function AddPrimaryKey()

'添加主键到[编号]字段

Dim strSQL As String

strSQL = "ALTER TABLE 表1 ADD CONSTRAINT PRIMARY_KEY " _

& "PRIMARY KEY (编号)"

CurrentProject.Connection.Execute strSQL

End Function

Function DropPrimaryKey()

'删除主键

Dim strSQL As String

strSQL = "ALTER TABLE 表1 Drop CONSTRAINT PRIMARY_KEY "

CurrentProject.Connection.Execute strSQL

End Function

SQL--JOIN之完全用法

来源：ACCESS设计在线

外联接。外联接可以是左向外联接、右向外联接或完整外部联接。

在 FROM 子句中指定外联接时，可以由下列几组关键字中的一组指定：

LEFT JOIN 或 LEFT OUTER JOIN。

左向外联接的结果集包括 LEFT OUTER

子句中指定的左表的所有行，而不仅仅是联接列所匹配的行。如果左表的某行在右表中没有匹配行，则在相关联的结果集行中右表的所有选择列表列均为空值。

RIGHT JOIN 或 RIGHT OUTER JOIN。

右向外联接是左向外联接的反向联接。将返回右表的所有行。如果右表的某行在左表中没有匹配行，则将为左表返回空值。

FULL JOIN 或 FULL OUTER JOIN。

完整外部联接返回左表和右表中的所有行。当某行在另一个表中没有匹配行时，则另一个表的选择列表列包含空值。如果表之间有匹配行，则整个结果集行包含基表的数据值。

仅当至少有一个同属于两表的行符合联接条件时，内联接才返回行。内联接消除与另一个表中的任何行不匹配的行。而外联接会返回 FROM

子句中提到的至少一个表或视图的所有行，只要这些行符合任何 WHERE 或 HAVING

搜索条件。将检索通过左向外联接引用的左表的所有行，以及通过右向外联接引用的右表的所有行。完整外部联接中两个表的所有行都将返回。

Microsoft&reg; SQL Server™ 2000 对在 FROM 子句中指定的外联接使用以下 SQL-92 关键字：

LEFT OUTER JOIN 或 LEFT JOIN

 

RIGHT OUTER JOIN 或 RIGHT JOIN

 

FULL OUTER JOIN 或 FULL JOIN

SQL Server 支持 SQL-92 外联接语法，以及在 WHERE 子句中使用 *= 和 =* 运算符指定外联接的旧式语法。由于 SQL-92

语法不容易产生歧义，而旧式 Transact-SQL 外联接有时会产生歧义，因此建议使用 SQL-92 语法。

使用左向外联接

假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和

Cheryl Carson）。

若要在结果中包括所有的作者，而不管出版商是否住在同一个城市，请使用 SQL-92 左向外联接。下面是 Transact-SQL 左向外联接的查询和结果：

USE pubs

SELECT a.au_fname, a.au_lname, p.pub_name

FROM authors a LEFT OUTER JOIN publishers p

ON a.city = p.city

ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC

下面是结果集：

au_fname au_lname pub_name

------------------- ------------------------------ -----------------

Reginald Blotchet-Halls NULL

Michel DeFrance NULL

Innes del Castillo NULL

Ann Dull NULL

Marjorie Green NULL

Morningstar Greene NULL

Burt Gringlesby NULL

Sheryl Hunter NULL

Livia Karsen NULL

Charlene Locksley NULL

Stearns MacFeather NULL

Heather McBadden NULL

Michael O'Leary NULL

Sylvia Panteley NULL

Albert Ringer NULL

Anne Ringer NULL

Meander Smith NULL

Dean Straight NULL

Dirk Stringer NULL

Johnson White NULL

Akiko Yokomoto NULL

Abraham Bennet Algodata Infosystems

Cheryl Carson Algodata Infosystems

(23 row(s) affected)

不管是否与 publishers 表中的 city 列匹配，LEFT OUTER JOIN 均会在结果中包含 authors

表的所有行。注意：结果中所列的大多数作者都没有相匹配的数据,因此，这些行的 pub_name 列包含空值。

使用右向外联接

假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和

Cheryl Carson）。SQL-92 右向外联接运算符 RIGHT OUTER JOIN

指明：不管第一个表中是否有匹配的数据，结果将包含第二个表中的所有行。

若要在结果中包括所有的出版商，而不管城市中是否还有出版商居住，请使用 SQL-92 右向外联接。下面是 Transact-SQL 右向外联接的查询和结果：

USE pubs

SELECT a.au_fname, a.au_lname, p.pub_name

FROM authors AS a RIGHT OUTER JOIN publishers AS p

ON a.city = p.city

ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC

下面是结果集：

au_fname au_lname pub_name

-------------------- ------------------------ --------------------

Abraham Bennet Algodata Infosystems

Cheryl Carson Algodata Infosystems

NULL NULL Binnet & Hardley

NULL NULL Five Lakes Publishing

NULL NULL GGG&G

NULL NULL Lucerne Publishing

NULL NULL New Moon Books

NULL NULL Ramona Publishers

NULL NULL Scootney Books

(9 row(s) affected)

使用谓词（如将联接与常量比较）可以进一步限制外联接。下例包含相同的右向外联接，但消除销售量低于 50 本的书籍的书名：

USE pubs

SELECT s.stor_id, s.qty, t.title

FROM sales s RIGHT OUTER JOIN titles t

ON s.title_id = t.title_id

AND s.qty > 50

ORDER BY s.stor_id ASC

下面是结果集：

stor_id qty title

------- ------ ---------------------------------------------------------

(null) (null) But Is It User Friendly?

(null) (null) Computer Phobic AND Non-Phobic Individuals: Behavior

Variations

(null) (null) Cooking with Computers: Surreptitious Balance Sheets

(null) (null) Emotional Security: A New Algorithm

(null) (null) Fifty Years in Buckingham Palace Kitchens

7066 75 Is Anger the Enemy?

(null) (null) Life Without Fear

(null) (null) Net Etiquette

(null) (null) Onions, Leeks, and Garlic: Cooking Secrets of the

Mediterranean

(null) (null) Prolonged Data Deprivation: Four Case Studies

(null) (null) Secrets of Silicon Valley

(null) (null) Silicon Valley Gastronomic Treats

(null) (null) Straight Talk About Computers

(null) (null) Sushi, Anyone?

(null) (null) The Busy Executive's Database Guide

(null) (null) The Gourmet Microwave

(null) (null) The Psychology of Computer Cooking

(null) (null) You Can Combat Computer Stress!

(18 row(s) affected)

有关谓词的更多信息，请参见 WHERE。

使用完整外部联接

若要通过在联接结果中包括不匹配的行保留不匹配信息，请使用完整外部联接。Microsoft&reg; SQL Server™ 2000 提供完整外部联接运算符 FULL

OUTER JOIN，不管另一个表是否有匹配的值，此运算符都包括两个表中的所有行。

假设在 city 列上联接 authors 表和 publishers 表。结果只显示在出版商所在城市居住的作者（本例中为 Abraham Bennet 和

Cheryl Carson）。SQL-92 FULL OUTER JOIN 运算符指明：不管表中是否有匹配的数据，结果将包括两个表中的所有行。

若要在结果中包括所有作者和出版商，而不管城市中是否有出版商或者出版商是否住在同一个城市，请使用完整外部联接。下面是 Transact-SQL

完整外部联接的查询和结果：

USE pubs

SELECT a.au_fname, a.au_lname, p.pub_name

FROM authors a FULL OUTER JOIN publishers p

ON a.city = p.city

ORDER BY p.pub_name ASC, a.au_lname ASC, a.au_fname ASC

下面是结果集：

au_fname au_lname pub_name

-------------------- ---------------------------- --------------------

Reginald Blotchet-Halls NULL

Michel DeFrance NULL

Innes del Castillo NULL

Ann Dull NULL

Marjorie Green NULL

Morningstar Greene NULL

Burt Gringlesby NULL

Sheryl Hunter NULL

Livia Karsen NULL

Charlene Locksley NULL

Stearns MacFeather NULL

Heather McBadden NULL

Michael O'Leary NULL

Sylvia Panteley NULL

Albert Ringer NULL

Anne Ringer NULL

Meander Smith NULL

Dean Straight NULL

Dirk Stringer NULL

Johnson White NULL

Akiko Yokomoto NULL

Abraham Bennet Algodata Infosystems

Cheryl Carson Algodata Infosystems

NULL NULL Binnet & Hardley

NULL NULL Five Lakes Publishing

NULL NULL GGG&G

NULL NULL Lucerne Publishing

NULL NULL New Moon Books

NULL NULL Ramona Publishers

NULL NULL Scootney Books

(30 row(s) affected)

 

金额阿拉伯数字转换为中文的存储过程

Private Function CCh(N1) As String

Select Case N1

Case 0

CCh = "零"

Case 1

CCh = "壹"

Case 2

CCh = "贰"

Case 3

CCh = "叁"

Case 4

CCh = "肆"

Case 5

CCh = "伍"

Case 6

CCh = "陆"

Case 7

CCh = "柒"

Case 8

CCh = "捌"

Case 9

CCh = "玖"

End Select

End Function

'名称： ChMoney

'得到数字 N1 的汉字大写

'最大为 千万位

'O 返回 ""

Public Function ChMoney(N1) As String

Dim tMoney As String

Dim lMoney As String

Dim tn '小数位置

Dim s1 As String '临时STRING 小数部分

Dim s2 As String '1000 以内

Dim s3 As String '10000

If N1 = 0 Then

ChMoney = " "

Exit Function

End If

If N1 < 0 Then

ChMoney = "负" + ChMoney(Abs(N1))

Exit Function

End If

tMoney = Trim(Str(N1))

tn = InStr(tMoney, ".") '小数位置

s1 = ""

If tn <> 0 Then

ST1 = Right(tMoney, Len(tMoney) - tn)

If ST1 <> "" Then

t1 = Left(ST1, 1)

ST1 = Right(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s1 = s1 + CCh(Val(t1)) + "角"

End If

If ST1 <> "" Then

t1 = Left(ST1, 1)

s1 = s1 + CCh(Val(t1)) + "分"

End If

End If

ST1 = Left(tMoney, tn - 1)

Else

ST1 = tMoney

End If

s2 = ""

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

s2 = CCh(Val(t1)) + s2

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s2 = CCh(Val(t1)) + "拾" + s2

Else

If Left(s2, 1) <> "零" Then s2 = "零" + s2

End If

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s2 = CCh(Val(t1)) + "佰" + s2

Else

If Left(s2, 1) <> "零" Then s2 = "零" + s2

End If

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s2 = CCh(Val(t1)) + "仟" + s2

Else

If Left(s2, 1) <> "零" Then s2 = "零" + s2

End If

End If

s3 = ""

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

s3 = CCh(Val(t1)) + s3

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s3 = CCh(Val(t1)) + "拾" + s3

Else

If Left(s3, 1) <> "零" Then s3 = "零" + s3

End If

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s3 = CCh(Val(t1)) + "佰" + s3

Else

If Left(s3, 1) <> "零" Then s3 = "零" + s3

End If

End If

If ST1 <> "" Then

t1 = Right(ST1, 1)

ST1 = Left(ST1, Len(ST1) - 1)

If t1 <> "0" Then

s3 = CCh(Val(t1)) + "仟" + s3

End If

End If

If Right(s2, 1) = "零" Then s2 = Left(s2, Len(s2) - 1)

If Len(s3) > 0 Then

If Right(s3, 1) = "零" Then s3 = Left(s3, Len(s3) - 1)

s3 = s3 & "万"

End If

ChMoney = IIf(s3 & s2 = "", s1, s3 & s2 & "元" & s1)

End Function

金额阿拉伯数字转换为中文的存储过程

也谈此内容。

以下同:

Private Function Num2Char(ByVal i As Integer) As String

If i >= 0 And i <= 9 Then

Num2Char = Mid$("零壹贰叁肆伍陆柒捌玖", i + 1, 1)

Else

Num2Char = ""

End If

End Function

Private Function Num2RMB(ByVal sFourBitString As String, Optional _

ByVal sUnit As String = "元", Optional ByVal bMustHeader As _

Boolean = False) As String

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

Dim vNum, i, RX, BR, hdr

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

BR = "仟佰拾元"

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

vNum = Trim(Str(Val(sFourBitString))) ' 最多四位

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

If (Len(vNum) < 4 And Len(vNum) > 0) And bMustHeader Then hdr = "零" _

Else hdr = ""

RX = ""

Do While Len(vNum) > 0

i = Right(vNum, 1)

If i > 0 Then

RX = Num2Char(i) + Right(BR, 1) + RX

Else

If Left(RX, 1) <> "零" Then RX = "零" + RX

End If

vNum = Left(vNum, Len(vNum) - 1)

BR = Left(BR, Len(BR) - 1)

Loop

RX = Left(RX, Len(RX) - 1)

If Right(RX, 1) = "零" Then ' 去除多余的零

RX = Left(RX, Len(RX) - 1)

End If

If Len(RX) > 0 Then

Num2RMB = hdr + RX + sUnit

Else

Num2RMB = RX + IIf(sUnit = "元", "元", "")

End If

End Function

Function GetDXJE(ByVal num As Currency) As String ' 得到大写金额

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

Dim vNum, vDec, ret, qb

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

vNum = Right(Format(Int(num), "000000000000"), 12) ' 取十二位整数

vDec = Right(Format(Int(num * 100 + 0.5), "00"), 2) ' 取小数点后两位并自动四舍五入

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

ret = Num2RMB(Left(vNum, 4), "亿", False)

If Len(ret) = 0 Then

ret = Num2RMB(Mid(vNum, 5, 4), "万", False)

Else

ret = ret + Num2RMB(Mid(vNum, 5, 4), "万", True)

End If

If Len(ret) = 0 Then

ret = Num2RMB(Right(vNum, 4), "元", False)

Else

ret = ret + Num2RMB(Right(vNum, 4), "元", True)

End If

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

If ret = "元" Then

ret = ""

qb = ""

Else

qb = "xx"

End If

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

If vDec = "00" And qb <> "" Then '1.00

ret = ret + "整"

End If

If vDec = "00" And qb = "" Then '0.00

ret = "(无金额)"

End If

If Left(vDec, 1) <> "0" And Right(vDec, 1) = 0 And qb <> "" Then '1.20

ret = ret + Num2Char(Left(vDec, 1)) + "角整"

End If

If Left(vDec, 1) = "0" And Right(vDec, 1) <> 0 And qb <> "" Then '1.03

ret = ret + "零" + Num2Char(Right(vDec, 1)) + "分"

End If

If Left(vDec, 1) <> "0" And Right(vDec, 1) <> 0 And qb <> "" Then '1.23

ret = ret + Num2Char(Left(vDec, 1)) + "角" + Num2Char(Right(vDec, 1)) + "分"

End If

If Left(vDec, 1) <> "0" And Right(vDec, 1) = 0 And qb = "" Then '0.20

ret = Num2Char(Left(vDec, 1)) + "角整"

End If

If Left(vDec, 1) = "0" And Right(vDec, 1) <> 0 And qb = "" Then '0.03

ret = Num2Char(Right(vDec, 1)) + "分"

End If

If Left(vDec, 1) <> "0" And Right(vDec, 1) <> 0 And qb = "" Then '0.23

ret = Num2Char(Left(vDec, 1)) + "角" + Num2Char(Right(vDec, 1)) + "分"

End If

GetDXJE = ret

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

End Function

 

 

ACCESS查询

分段统计人数

这样一个表  tblScore：

班级  姓名  总分  语文  数学

1班   a     601   108   120

2班   b     589   112   133

3班   C     551   98    145

2班   D     502   80    124

1班   E     508   90    85

3班   F     561   97    135

 

TRANSFORM Count(tblScore.总分) AS 总分OfCount

SELECT tblScore.班级

FROM tblScore

GROUP BY tblScore.班级

PIVOT Switch([总分]>=600,">=600",[总分]>=550 And [总分]<600,"550-599",[总分]>=500 And

[总分]<550,"500-549",True,"Other") In (">=600","550-599","500-549","Other");

 

可得到第一個查詢

班级 总分600分以上人数  总分550-600人数  总分550以下人数

1班  1                     0              1               

2班  0                     1              1               

3班  0                     2              0    

 

用代码在ACCESS中生成永久查询

来源：竹笛整理的技巧集

dim strSQL as string

dim qdf as QueryDef

strSQL = "SELECT * from tblaa" 'tblaa为表

Set qdf = CurrentDb.CreateQueryDef("创建的查询", strSQL)

DoCmd.OpenQuery qdf.Name

用代码删除一个已存在的查询

来源：爱赛思应用俱乐部 wxjgw

Dim Query1 As QueryDef

CurrentDb.QueryDefs.Refresh　　　　　　　

For Each Query1 In CurrentDb.QueryDefs　　

　　If Query1.Name = "想要删除的查询名称" Then

　　　　CurrentDb.QueryDefs.Delete Query1.Name

　　　　Exit For

End If

Next Query1

 

使用ADO和SQL语句建立一个新查询

来源：ACCESS中国 huanghai

Dim cat  As New ADOX.Catalog

Dim cmd As New ADODB.Command

Set cat.ActiveConnection = CurrentProject.Connection

cmd.CommandText = "SELECT * FROM 表1"

cat.Views.Append "newView", cmd

 

以窗体的文体框为条件进行模糊查询时查询的设计视图中准则：

Like IIf(IsNull([Forms]![存书查询窗体]![作者]),'*','*' & [Forms]![存书查询窗体]![作者] & '*')

 

用VBA代码生成一个条件组合的字符串作为子窗体的窗体筛选的条件来实现窗体的多条件查询。

 

Option Compare Database

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

'刘小军（ALEX），2003-5-22

'

'由浅入深的介绍几种最常用的利用主/子窗体来实现查询的方法，

'使初学者和有一定VBA基础的人可以更好的使用窗体查询这种手段。

'

'本例程是讲解用VBA代码生成一个条件组合的字符串作为子窗体的

'窗体筛选的条件来实现窗体的多条件查询。

'

'欢迎访问 ACCESS编程应用网 www.accxp.com

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

 

Private Sub cmd查询_Click()

On Error GoTo Err_cmd查询_Click

 

    Dim strWhere As String  '定义条件字符串

   

    strWhere = "" '设定初始值－空字符串

   

    '判断【书名】条件是否有输入的值

    If Not IsNull(Me.书名) Then

        '有输入

        strWhere = strWhere & "([书名] like '*" & Me.书名 & "*') AND "

    End If

   

    '判断【类别】条件是否有输入的值

    If Not IsNull(Me.类别) Then

        '有输入

        strWhere = strWhere & "([类别] like '" & Me.类别 & "') AND "

    End If

 

    '判断【作者】条件是否有输入的值

    If Not IsNull(Me.作者) Then

        '有输入

        strWhere = strWhere & "([作者] like '*" & Me.作者 & "*') AND "

    End If

 

    '判断【出版社】条件是否有输入的值

    If Not IsNull(Me.出版社) Then

        '有输入

        strWhere = strWhere & "([出版社] like '" & Me.出版社 & "') AND "

    End If

 

    '判断【单价】条件是否有输入的值，由于有【单价开始】【单价截止】两个文本框

    '所以要分开来考虑

    If Not IsNull(Me.单价开始) Then

        '【单价开始】有输入

        strWhere = strWhere & "([单价] >= " & Me.单价开始 & ") AND "

    End If

    If Not IsNull(Me.单价截止) Then

        '【单价截止】有输入

        strWhere = strWhere & "([单价] <= " & Me.单价截止 & ") AND "

    End If

   

   

    '判断【进书日期】条件是否有输入的值，由于有【进书日期开始】【进书日期截止】两个文本框

    '所以要分开来考虑

    If Not IsNull(Me.进书日期开始) Then

        '【进书日期开始】有输入

        strWhere = strWhere & "([进书日期] >= #" & Format(Me.进书日期开始, "yyyy-mm-dd") &

"#) AND "

    End If

    If Not IsNull(Me.进书日期截止) Then

        '【进书日期截止】有输入

        strWhere = strWhere & "([进书日期] <= #" & Format(Me.进书日期截止, "yyyy-mm-dd") &

"#) AND "

    End If

   

    '如果输入了条件，那么strWhere的最后肯定有" AND "，这是我们不需要的，

    '要用LEFT函数截掉这5个字符。

    If Len(strWhere) > 0 Then

        '有输入条件

        strWhere = Left(strWhere, Len(strWhere) - 5)

    End If

   

    '先在立即窗口显示一下strWhere的值，代码调试完成后可以取消下一句

    Debug.Print strWhere

   

   

    '让子窗体应用窗体查询

    Me.存书查询子窗体.Form.Filter = strWhere

    Me.存书查询子窗体.Form.FilterOn = True

   

    '在子窗体筛选后要运行一下自编子程序CheckSubformCount()

    Call CheckSubformCount

 

 

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

'刘小军(Alex) 2003-5-22

'这里将使用DAO来改变查询的SQL语句，必须先在“工具”→“引用”中选择

'Microsoft DAO 3.6 Object Library.

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

 

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

    Dim strWhere, strSQL As String

   

    strWhere = Me.存书查询子窗体.Form.Filter

    If strWhere = "" Then

        '没有条件

        strSQL = "SELECT * FROM [存书查询]"

    Else

        '有条件

        strSQL = "SELECT * FROM [存书查询] WHERE " & strWhere

    End If

   

    Set qdf = CurrentDb.QueryDefs("查询结果")

    qdf.SQL = strSQL

    qdf.Close

   

    Set qdf = Nothing

   

    DoCmd.OutputTo acOutputQuery, "查询结果", acFormatXLS, , True

 

   

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

'刘小军(Alex) 2003-5-22

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

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

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

 

    Dim ctl As Control

   

    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

   

    '取消子窗体的筛选

    Me.存书查询子窗体.Form.Filter = ""

    Me.存书查询子窗体.Form.FilterOn = False

   

    '在子窗体取消筛选后要运行一下自编子程序CheckSubformCount()

    Call CheckSubformCount

 

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 = "藏书情况报表"

    strWhere = Me.存书查询子窗体.Form.Filter

 

    '在打开报表的同时把子窗体的筛选条件字符串也传递给报表，

    '这样地话报表也会显示和子窗体相同的记录。

    DoCmd.OpenReport stDocName, acPreview, , strWhere

   

Exit_cmd预览报表_Click:

    Exit Sub

 

Err_cmd预览报表_Click:

    MsgBox Err.Description

    Resume Exit_cmd预览报表_Click

   

End Sub

 

 

Private Sub CheckSubformCount()

'刘小军(Alex) 2003-5-22

'这是一个自编子程序，专门用来检查子窗体上的记录数，

'以便修改主窗体上的“计数”和“合计”的控件来源，

'以防止出现“#错误”。

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

 

    If Me.存书查询子窗体.Form.Recordset.RecordCount > 0 Then

        '子窗体的记录数>0

        Me.计数.ControlSource = "=[存书查询子窗体].[Form].[txt计数]"

        Me.合计.ControlSource = "=[存书查询子窗体].[Form].[txt单价合计]"

    Else

        '子窗体的记录数=0

        Me.计数.ControlSource = "=0"

        Me.合计.ControlSource = "=0"

    End If

   

   

End Sub

 

用VBA代码+DAO生成带条件的交叉表查询

Option Compare Database

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

'刘小军（ALEX），2003-5-26

'

'由浅入深的介绍几种最常用的利用主/子窗体来实现查询的方法，

'使初学者和有一定VBA基础的人可以更好的使用窗体查询这种手段。

'

'本例程是讲解用VBA代码+DAO生成带条件的交叉表查询。

'

'欢迎访问 ACCESS编程应用网 www.accxp.com

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

 

Private Sub cmd查询_Click()

On Error GoTo Err_cmd查询_Click

 

    Dim strWhere As String  '定义条件字符串

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

    Dim strSQL As String

   

    strWhere = "" '设定初始值－空字符串

   

    '判断【类别】条件是否有输入的值

    If Not IsNull(Me.类别) Then

        '有输入

        strWhere = strWhere & "([类别] like '" & Me.类别 & "') AND "

    End If

 

    '判断【出版社】条件是否有输入的值

    If Not IsNull(Me.出版社) Then

        '有输入

        strWhere = strWhere & "([出版社] like '" & Me.出版社 & "') AND "

    End If

 

    '判断【单价】条件是否有输入的值，由于有【单价开始】【单价截止】两个文本框

    '所以要分开来考虑

    If Not IsNull(Me.单价开始) Then

        '【单价开始】有输入

        strWhere = strWhere & "([单价] >= " & Me.单价开始 & ") AND "

    End If

    If Not IsNull(Me.单价截止) Then

        '【单价截止】有输入

        strWhere = strWhere & "([单价] <= " & Me.单价截止 & ") AND "

    End If

   

   

    '判断【进书日期】条件是否有输入的值，由于有【进书日期开始】【进书日期截止】两个文本框

    '所以要分开来考虑

    If Not IsNull(Me.进书日期开始) Then

        '【进书日期开始】有输入

        strWhere = strWhere & "([进书日期] >= #" & Format(Me.进书日期开始, "yyyy-mm-dd") &

"#) AND "

    End If

    If Not IsNull(Me.进书日期截止) Then

        '【进书日期截止】有输入

        strWhere = strWhere & "([进书日期] <= #" & Format(Me.进书日期截止, "yyyy-mm-dd") &

"#) AND "

    End If

   

    '如果输入了条件，那么strWhere的最后肯定有" AND "，这是我们不需要的，

    '要用LEFT函数截掉这5个字符。

    If Len(strWhere) > 0 Then

        '有输入条件

        strWhere = Left(strWhere, Len(strWhere) - 5)

    End If

   

    '先在立即窗口显示一下strWhere的值，代码调试完成后可以取消下一句

    'Debug.Print strWhere

   

    '根据是否有条件来设定交叉表查询的SQL语句

    If Len(strWhere) > 0 Then

        strSQL = "TRANSFORM Sum(存书查询.单价) AS 单价之Sum SELECT 存书查询.类别 FROM 存书查询 "

        strSQL = strSQL & "WHERE(" & strWhere

        strSQL = strSQL & ") GROUP BY 存书查询.类别 PIVOT Format([进书日期],'yyyy/mm')"

    Else

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

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

                 " FROM 存书查询" & _

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

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

    End If

   

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

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

    qdf.SQL = strSQL

    qdf.Close

   

    Set qdf = Nothing

   

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

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

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

   

    '刷新计数和合计显示

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

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

   

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

'刘小军(Alex) 2003-5-27

'由于前面我们已经通过DAO修改了“存书查询_交叉表”的SQL语句，

'所以这里我们直接导出就可以了。

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

 

  

    DoCmd.OutputTo acOutputQuery, "存书查询_交叉表", acFormatXLS, , True

 

   

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

'刘小军(Alex) 2003-5-27