如何在不建立外部链接表的情况下，如何把另一数据库的查询结果赋值给窗体的子窗体 - Office中国论坛/Access中国论坛

Private Sub cmd查询_Click()
Dim rst As dao.Recordset
Dim db As dao.Database
Dim Shop As String, Prod As String, GetRow
'定义查询条件
If IsNull(Me.t店铺) Then
Shop = "'*'"
Else
Shop = "'*" & Me.t店铺 & "*'"
End If
If IsNull(Me.t产品) Then
Prod = "'*'"
Else
Prod = "'*" & Me.t产品 & "*'"
End If
'定义sql查询语句
ssql = "SELECT 订单明细.店铺名称, 订单明细.产品, Sum(订单明细.规格1) as 规格1, " _
& "Sum(订单明细.规格2) As 规格2, Sum(订单明细.规格3) As 规格3 FROM 订单明细 " _
& "GROUP BY 订单明细.店铺名称, 订单明细.产品 " _
& "HAVING 订单明细.店铺名称 Like " & Shop & " And 订单明细.产品 Like " & Prod
'打开数据库并连接记录集
Set db = dao.OpenDatabase(CurrentProject.Path & "\data.mdb")
Set rst = db.OpenRecordset(ssql)
'绑定窗体数据源
Set Me.订单汇总子窗体.Form.Recordset = rst
Forms!订单查询!订单汇总子窗体!t店铺名.ControlSource = "店铺名称"
Forms!订单查询!订单汇总子窗体!t产品.ControlSource = "产品"
Forms!订单查询!订单汇总子窗体!t规格1.ControlSource = "规格1"
Forms!订单查询!订单汇总子窗体!t规格2.ControlSource = "规格2"
Forms!订单查询!订单汇总子窗体!t规格3.ControlSource = "规格3"
End Sub

复制代码

Private Sub cmd查询_Click()
On Error GoTo Err_Handler
Dim rst As Object
Dim strShop As String
Dim strProd As String
Dim strSQL As String
'关闭屏幕刷新
Application.Echo False
'设置鼠标指针为沙漏形状
DoCmd.Hourglass True
'定义子窗体的数据源的SQL语句
Me.t店铺 = Trim(Nz(Me.t店铺, ""))
Me.t产品 = Trim(Nz(Me.t产品, ""))
strShop = IIf(Len(Me.t店铺) = 0, "%", "%" & Me.t店铺 & "%")
strProd = IIf(Len(Me.t产品) = 0, "%", "%" & Me.t产品 & "%")
strSQL = "SELECT 订单明细.店铺名称, 订单明细.产品, Sum(订单明细.规格1) as 规格1," _
& " Sum(订单明细.规格2) As 规格2, Sum(订单明细.规格3) As 规格3 FROM 订单明细" _
& " GROUP BY 订单明细.店铺名称, 订单明细.产品" _
& " HAVING 订单明细.店铺名称 Like '" & strShop & "' And 订单明细.产品 Like '" & strProd & "'"
'设置子窗体的数据源
If GetRecordset(rst, strSQL, 1, 1) Then
SetFieldName True
Set Me.Controls("订单汇总子窗体").Form.Recordset = rst
Else
SetFieldName False
End If
Exit_Handler:
'恢复鼠标指针
DoCmd.Hourglass False
'打开屏幕刷新
Application.Echo True
Exit Sub
Err_Handler:
MsgBox Err.Descripton, vbExclamation, "读取数据"
Resume Exit_Handler
End Sub
Private Sub SetFieldName(Optional ByVal blnDisplayRecordset As Boolean = True)
If blnDisplayRecordset Then
Forms!订单查询!订单汇总子窗体!t店铺名.ControlSource = "店铺名称"
Forms!订单查询!订单汇总子窗体!t产品.ControlSource = "产品"
Forms!订单查询!订单汇总子窗体!t规格1.ControlSource = "规格1"
Forms!订单查询!订单汇总子窗体!t规格2.ControlSource = "规格2"
Forms!订单查询!订单汇总子窗体!t规格3.ControlSource = "规格3"
Else
Forms!订单查询!订单汇总子窗体!t店铺名.ControlSource = ""
Forms!订单查询!订单汇总子窗体!t产品.ControlSource = ""
Forms!订单查询!订单汇总子窗体!t规格1.ControlSource = ""
Forms!订单查询!订单汇总子窗体!t规格2.ControlSource = ""
Forms!订单查询!订单汇总子窗体!t规格3.ControlSource = ""
End If
End Sub

复制代码

Option Compare Database '使用数据库的字符串比较方式
Option Explicit '变量在使用前必须进行显式声明
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Public cn As Object '定义全程变量：数据链接对象（ADODB.Connection），用来保存连接数据库信息变量。
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'=======================================
' 建立与后台数据库的链接（无链接表方式）
'=======================================
Public Function ADODB_Connect(Optional ByVal strDatabase As String = ".\Data.MDB", Optional ByVal strPwd As String = "") As Boolean
On Error GoTo Err_ADODB_Connect
Dim strConnect As String
strDatabase = Trim(Nz(strDatabase, ""))
'如果是简写的路径则转换为绝对路径
If strDatabase Like ".\*" Then strDatabase = CurrentProject.Path & Mid(strDatabase, 2)
'如果是相对路径则转换为绝对路径
If Left(strDatabase, 1) = "" Then strDatabase = Mid(CurrentProject.Path, 1, 2) & strDatabase
If Not strDatabase Like "[A-z]:*" Then strDatabase = CurrentProject.Path & "" & strDatabase
'定义ACCESS链接串
strConnect = "Provider=Microsoft.Jet.OLEDB.4.0" & ";Data Source=" & strDatabase & ";Jet OLEDB:Database Password=" & strPwd
'用ADO通过OLEDB直接连接数据库
Set cn = Nothing
Set cn = CreateObject("ADODB.Connection")
cn.ConnectionString = strConnect
cn.CursorLocation = adUseClient
cn.ConnectionTimeout = 15
cn.CommandTimeout = 30
cn.Open
ADODB_Connect = True
Exit_ADODB_Connect:
Exit Function
Err_ADODB_Connect:
ADODB_Connect = False
MsgBox "连接后台数据库【" & strDatabase & "】失败！" \ Chr(10) & Chr(10) & "出错原因：" & Err.Description, 64, "出错信息"
'并释放变量
Set cn = Nothing
Resume Exit_ADODB_Connect
End Function
'=======================================
' 打开记录集
'=======================================
Public Function GetRecordset(ByRef rst As Object, _
ByRef strSQL As String, _
Optional ByRef intOpenKeyset As Integer = adOpenKeyset, _
Optional ByRef intLockOptimistic As Integer = adLockReadOnly, _
Optional ByRef IsCurrentMDB As Boolean = False) As Boolean
On Error GoTo Err_GetRecordset
RetryOpen:
'打开ADO记录集
Set rst = Nothing
Set rst = CreateObject("ADODB.Recordset")
If IsCurrentMDB Then
'当前MDB
rst.Open strSQL, CurrentProject.AccessConnection, intOpenKeyset, intLockOptimistic
Else
With rst
.Source = strSQL
.ActiveConnection = cn
.CursorLocation = adUseClient '3
.CursorType = intOpenKeyset
.LockType = intLockOptimistic
.Open
End With
End If
GetRecordset = True
If rst.RecordCount > 0 Then rst.MoveFirst
Exit_GetRecordset:
Exit Function
Err_GetRecordset:
If Not IsCurrentMDB Then
Dim intCounter As Integer
'与数据库断开连接，则重新连接一次。
If Err.Number = 91 Or cn Is Nothing Then
If intCounter = 0 Then
intCounter = intCounter + 1
If ADODB_Connect Then Resume RetryOpen
End If
ElseIf Err.Number = 3709 Then
If intCounter = 0 Then
intCounter = intCounter + 1
Sleep 1000
Resume RetryOpen
End If
ElseIf Err.Number = -2147217865 Then
If intCounter = 0 Then
intCounter = intCounter + 1
Sleep 1000
Resume
End If
End If
End If
GetRecordset = False
'并释放变量
Set rst = Nothing
'显示错误信息
MsgBox Err.Description, vbExclamation, "打开记录集过程：GetRecordset"
Resume Exit_GetRecordset
End Function

复制代码