ACCESS-VBA编程

ACSSESS-VBA

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

通过英特网的ACCESS联接 在ACCESS中使用ADO： Private Sub ABC_Click()

Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset cn.OPEN \

rs.OPEN \ rs.ABC App.Path & \rs.Close cn.Close

MsgBox (\End Sub

Private Sub OPEN_Click() Dim strConnect As String

strConnect = \Dim rs As New ADODB.Recordset

rs.OPEN \远程服务器的IP/test/testdata.dat\Do While Not rs.EOF

Debug.Print rs(\rs.MoveNext Loop End Sub

将用户输入的身份证号15位数据转化为18位。 Function IDCode15to18(sCode15 As String) As String

'* 功能:将15的身份证号升为18位(根据GB 11643-1999) '* 参数:原来的号码

'* 返回:升位后的18位号码 Dim i As Integer Dim num As Integer Dim code As String num = 0

IDCode15to18 = Left(sCode15, 6) + \' 计算校验位

For i = 18 To 2 Step -1

num = num + (2 ^ (i - 1) Mod 11) * (Mid(IDCode15to18, 19 - i, 1)) Next i

num = num Mod 11 Select Case num Case 0 code = \Case 1 code = \

17-87

ACSSESS-VBA

Case 2 code = \Case Else

code = Trim(Str(12 - num)) End Select

IDCode15to18 = IDCode15to18 + code End Function

据身份证号自动输入出生日期 Dim Length As Integer

Length = Len(Me.[身份证号]) If Not IsNull(Length) Then If Length = 15 Then

Me.[性别] = IIf(Val(Mid(Me.身份证号, 15, 1)) / 2 = Int(Val(Mid(Me.身份证号, 15, 1)) / 2), \女\\男\

Me.[出生日期] = \身份证号], 7, 2) & \身份证号], 9, 2) & \身份证号], 11, 2)

ElseIf Length = 18 Then

Me.[性别] = IIf(Val(Mid(Me.身份证号, 17, 1)) / 2 = Int(Val(Mid(Me.身份证号, 17, 1)) / 2), \女\\男\

Me.[出生日期] = Mid([身份证号], 7, 4) & \身份证号], 11, 2) & \身份证号], 13, 2) Else

MsgBox \身份证号错误！\End If End If

两行代码打开另一数据库 Private Sub 命令4_Click()

On Error GoTo Err_命令4_Click Dim strDb As String strDb = \

SendKeys \Exit_命令4_Click: Exit Sub

Err_命令4_Click:

MsgBox Err.Description Resume Exit_命令4_Click End Sub

实现打开外部数据库中的报表。

Private Declare Function apiSetForegroundWindow Lib \Alias \(ByVal hwnd As Long) _ As Long

Private Declare Function apiShowWindow Lib \Alias \

18-87

ACSSESS-VBA

(ByVal hwnd As Long, _

ByVal nCmdShow As Long) _ As Long

Private Const SW_MAXIMIZE = 3 Private Const SW_NORMAL = 1

Function fOpenRemoteReport(strMDB As String, strReport As String, _ Optional intView As Variant) _ As Boolean

' strMDB: 外部数据库名称(含路径) ' strReport: 报表名称

' intView: 报表的打开方式

Dim objAccess As Access.Application Dim lngRet As Long

On Error GoTo fOpenRemoteReport_Err

If IsMissing(intView) Then intView = acViewPreview If Len(Dir(strMDB)) > 0 Then

Set objAccess = New Access.Application With objAccess

lngRet = apiSetForegroundWindow(.hWndAccessApp)

lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL) ' 第一次调用ShowWindow似乎不做任何事情

lngRet = apiShowWindow(.hWndAccessApp, SW_NORMAL) .OpenCurrentDatabase strMDB

.DoCmd.OpenReport strReport, intView Do While Len(.CurrentDb.Name) > 0 DoEvents Loop End With End If

fOpenRemoteReport_Exit: On Error Resume Next objAccess.Quit

Set objAccess = Nothing Exit Function

fOpenRemoteReport_Err: fOpenRemoteReport = False Select Case Err.Number Case 7866:

' mdb 已经被用独占方式打开

MsgBox \该数据库：\

vbCrLf & \已经被用独占方式打开！\

& vbCrLf & \请重新用共享方式打开，再试一次！\vbExclamation + vbOKOnly, \不能打开数据库\Case 2103:

19-87

ACSSESS-VBA

' 报表不存在

MsgBox \在这个\数据库中不存在该报表：\vbCrLf & vbCrLf , _

vbExclamation + vbOKOnly, \报表不存在\Case 7952:

' 用户关闭了这个 mdb fOpenRemoteReport = True Case Else:

MsgBox \错误#: \vbCritical + vbOKOnly, \运行时错误\End Select

Resume fOpenRemoteReport_Exit End Function

为列表框定数据源 Dim str3 As String

str3 = \jhd_mx_jiage.wp_leibie AS 类别, jhd_mx_jiage.wp_migceg AS 名称, jhd_mx_jiage.wp_xighao AS 型号, jhd_mx_jiage.jhmx_danwei AS 单位, jhd_mx_jiage.jhmx_danjia AS 单价FROM jhd_mx_jiage \& \where jhd_mx_jiage.wp_leibie='\Me.Listjhwp.RowSource = str3 Me.Listjhwp.Requery

为组合框、子窗体设置数据源

下面的示例将组合框的 RowSourceType 属性设为“Table/Query”，然后将 RowSource 属性设为“雇员列表”查询。

Forms!Employees!cmboNames.RowSourceType = \Forms!Employees!cmboNames.RowSource = \一：

Dim str1 As String

str1 = \ziyuag.zy_daihao, ziyuag.zy_mima,ziyuag.zy_ziwu,ziyuag.zy_xigmig FROM ziyuag \Me.Child6zy.Form.RecordSource = str1 Me.Child6zy.Requery 二： 子窗体.FORM.recordsourse=\ziyuag.zy_daihao, ziyuag.zy_mima,ziyuag.zy_ziwu,ziyuag.zy_xigmig FROM ziyuag \& \where zy_daihao='\& Text8dldh & \三：

Private Sub Command38_Click() Dim sjy As String Dim pd As Integer pd = True

sjy = \病历明细表.* FROM 病历明细表\If Not IsNull(Text0) Then If pd Then

20-87