access-VBA编程 第四章 数据输入、查询、计算、连接3

时　间:2009-02-18 08:51:06
作　者:UMVsoft整理   ID：1445  城市：上海
摘　要:VBA
正　文:

第四章 数据输入、查询、计算、连接3

怎样使窗体一打开就定位到指定记录上
定义了一个变量lngbh，要窗体打开时显示ID=Lngbh的这条记录。
DoCmd.OpenForm "formname", acNormal, , "ID =" & LNGBH, acFormEdit, acWindowNormal
使用API函数sendmessage，获得光标所在行和列。
Sub getcaretpos(byval TextHwnd&,LineNo&,ColNo&)
注释：TextHwnd为TextBox的hWnd属性值， LineNo为所在行数，ColNo为列数
dim I&,j&,k&
注释：获取起始位置到光标所在位置字节数 I=SendMessage(TextHwnd,&HB0&,0,0) j=I/2^16
注释：确定所在行
LineNo=SendMessage(TextHwnd,&HC9&,j,0)+1
注释：确定所在列
k=SendMessage(TextHwnd,&HBB&,-1,0)
ColNo=j-k+1
End sub
如何在打开窗体时自动到相应记录
用法:
DoCmd.RunCommand acCmdRecordsGoToNew
acCmdRecordsGoToFirst 移到第一条记录
acCmdRecordsGoToLast 移到最后一条记录
acCmdRecordsGoToNew 新增一条记录
acCmdRecordsGoToNext 移到下一条记录
acCmdRecordsGoToPrevious 移到上一条记录
判断记录的位置
来自：ACCESS中国 ysf
me.Recordset.AbsolutePosition = 0 '第一条记录
me.Recordset.AbsolutePosition = me.Recordset.RecordCount -1 '最后一条记录
me.Recordset.AbsolutePosition=-1 '第一条记录前 me.Recordset.bof=true
me.Recordset.AbsolutePosition=me.Recordset.RecordCount '最后一条记录后 me.Recordset.eof=true
me.Recordset.AbsolutePosition=n '第n+1条记录
判断为是否新增记录
me.newrecord=true
me.newrecord=false
自动编号
一：
=IIf(Left(Nz(DMax("[jhd_id]","jinhuodan",""),0),6)<>Format(Date(),"yyyymm"),Format(Date(),"yyyymm") & "001",Format(Date(),"yyyymm") & Format(Val(Right(Nz(DMax("[jhd_id]","jinhuodan",""),0),3))+1,"000"))
二：
=nz(DLookUp("编号","登记表","[id]=DMax('id','登记表')"))+1
自动编号
方法一按时间自动编号：
dim a,b

a=dmax("[自动编号]","编号表")+1
b=format(date(),"yyyymm") & 00
if a>b then
me.自动编号=a
else
me.自动编号=b+1
end if
方法二，按时间自动编号：
Dim a As String
a = Nz(DMax("销售单号", "销售帐单", ""), 0)
If Left(a, 6) <> Format(Date, "yyyymm") Then
销售单号 = Format(Date, "yyyymm") & "01"
Else
销售单号 = Format(Date, "yyyymm") & Format(Val(Right(a, 2)) + 1, "00")
End If
方法三，按月分类自动编号：
Dim id, date2 As String
date2 = "GF" & [部门代码] & Format([入库日期], "YYYYMM")
id = DMax("[rk编号]", "[入库单]", "[rk编号] Like '" & date2 & "???'")
If IsNull(id) Then
Me.RK编号 = date2 & "001"
Else
Me.RK编号 = date2 & Format(CStr(CInt(Right(id, 3)) + 1), "000")
End If
按任意输入的日期值的年月自动编号
Dim a, b, c
c = Format(Me.凭证日期, "yyyymm")
b = Nz(c, 0) * 1000
a = Nz(DMax("[凭证号码]", "凭证", "format(凭证.凭证日期,'yyyymm')=format([forms]![凭证录入].[凭证日期],'yyyymm')"), 0) + 1
If a > b Then
Me.凭证号码 = a
Else:
Me.凭证号码 = b + 1
End If
新增一条记录时使用Right及DMax函数让字段的数字部分自动加1
答：使用Right及DMax函数返回字段“FOO”的数字部分的最大值，然后加1
表达式为：
="REC-" & right(DMax("FOO", "FOOTable"), _
Len(DMax("FOO", "FOOTable")) - _
InStr(1, DMax("FOO", "FOOTable"), "-")) + 1
注意：但如果很多用户或多个程序都使用DMax去实现这个结果的话，特别在一个很大的表中这个过程会很慢，所以建议使用DefaultValue，它仅仅使用DMax一次
程序如下，写在更新事件中
Private Sub SomeField_AfterUpdate()
Dim strMax as string
strMax =DMax("FOO", "FOOTable")

me!HiddenFooCtl = "REC-" & right(strMax, len(strMax) - Instr(1,strMax, "-")) +1
End Sub
用按钮在窗体中添加新记录
Private Sub 添加新记录_Click()
DoCmd.GoToRecord , , acNewRec
End Sub
从文本框里输入新的数据库路径，然后更新链接。
Private Sub Command0_Click()
Dim cat As ADOX.Catalog
Dim tdf As ADOX.Table
Me.txtDBnewNAME.SetFocus
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = CurrentProject.Connection
Set tdf = cat.Tables("mytable")
tdf.Properties("jet oledb:link datasource")=Me.txtDBnewNAME.Text
End Sub
查看当前库的路径
方法1.
= CurrentProject.Path
方法2.
Dim DBLongname, DBName, DBDir As String
DBLongname = CodeDb.Name
DBName = Dir(DBLongname)
DBDir = Left(DBLongname, Len(DBLongname) - Len(DBName))
MsgBox "数据库所在目录：" & DBDir
用ADO打开链接表
这是我以前十分头痛的问题，不知道那一堆一串的是什么意思现在知道了，这个是打开ACCESS的，打开别的表不在此讨论之内。
Dim appAccess As ADODB.Connection
Dim strCn, temp As String
Dim cat As ADOX.Catalog
Dim rstEmployees As ADODB.Recordset
Dim intloop As Integer
Dim tbl1, tblEmp As ADOX.Table
Dim idx As ADOX.Index
strCn = "provider=microsoft.jet.oledb.4.0;password=;user id=admin; data source=" _
& "C:\Program Files\zhanyexing\123.mdb;Jet OLEDB:Database Password=；"
Set appAccess = New ADODB.Connection
appAccess.Open strCn
Set cat = New ADOX.Catalog
cat.ActiveConnection = appAccess
路径改成自己的，如果有密码则在红色的Password=后面写上正确的密码，别的照抄就行了
如何更该链接表的设置
来源：ALEX
例如，数据库当前的路径可以用application.CurrentProject.Path得到，然后用 application.CurrentProject.Path + "\link\abc.mdb"就可以指向数据库安装目录下面 link子目录下的ABC.MDB。

如何在ADP启动时,判断数据库连接是否有效并重新连接
这是微软MSDN中，在ADP项目中创建ADP的数据库的默认连接的代码
Public Function sCreateConnection(sSvrName As String, sUID As String, sPWD As String, sDatabase As String) As String
'********************************************************************
'该函数在ADP中检查连接，如果没有，它将通过输入参数创建一个连接
'
'输入:
' 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:sst95@21cn.com", vbNullString, vbNullString, 0

上一节 下一节