刷新表链接 '
' '
' 这个模块包含用于刷新到后台数据库表的链接的函数，如果那 '
' 些表可用的话。改写自罗斯文商贸数据库！这可是宝库！ '
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit ' 要求变量在使用以前明确声明
Option Compare Database ' 字符串比较使用数据库次序
'=======================================================================
'设定部分：
Private Const CheckTableName = "培训项目"
'"培训项目"表是我的实例数据库中的表，你应该改成你自己后台数据库的链接表名。
Private Const TablePassword = "12345"
'"12345"是我的后台数据库打开的密码，你应该改成你自己后台数据库的打开密码。
Private Const conAppTitle = "前台数据库"
Private Const conBackAppTitle = "后台数据库.mdb"
'"前台数据库"是本数据库的名称，可以不用加“.mdb”
'"后台数据库.mdb"是链接的后台数据库的名称，必须有".mdb"
'
'以下不用改
'=======================================================================
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Type MSA_OPENFILENAME
' 用于打开文件对话框过滤器的过滤字符串。
' 使用 MSA_CreateFilterString() 来创建它。
' 默认(Default) = 所有文件, *.*
strFilter As String
' 用于显示的初始过滤器。
' 默认(Default) = 1
lngFilterIndex As Long
' 对话框所作用的初始目录。
' 默认(Default) = 当前工作目录。
strInitialDir As String
' 初始文件名。
' 默认(Default) = ""
strInitialFile As String
strDialogTitle As String
' 默认的文件扩展名，如果用户没有指定一个的话，将使用它。
' 默认(Default) = 系统值 (打开文件， 保存文件)。
strDefaultExtension As String
' 所使用的标志 (参看“常量”(Const) 列表)
' 默认(Default) = 无标志。
lngFlags As Long
' 所选取文件的完整路径。在打开文件(OpenFile)时，如果用户点取了
' 一个不存在的文件，将只返回 "File Name"(文件名)框中的文本。
strFullPathReturned As String
' 所选取文件的文件名。
strFileNameReturned As String
' 文件名(strFileNameReturned)开始位置在完整路径中的偏移。
intFileOffset As Integer
'文件扩展名开始位置在完整路径(strFullPathReturned)中的偏移。
intFileExtension As Integer
End Type
Const ALLFILES = "所有文件"
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter 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
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Function FindFile(strSearchPath, strTitle, strFilterFilename, strFilterExtname) As String
' 显示打开文件对话框让用户定位
' 特定的文件。返回文件的完整路径。
Dim msaof As MSA_OPENFILENAME
' 给对话框设置选项。
Msaof.strDialogTitle = strTitle
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString(strFilterFilename, strFilterExtname)
' 调用打开文件对话框例程。
MSA_GetOpenFileName msaof
' 返回路径和文件名。
FindFile = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' 从所传递的实参中创建一个过滤器字符串。
' 如果没有传递进任何实参，将返回 "" 。
' 期望传进偶数个实参(过滤字符串、扩展名)， 但
' 如果传进奇数个，将附加 *.* 。
Dim strFilter As String
Dim intRet As Integer
Dim intNum As Integer
intNum = Ubound(varFilt)
If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
Else
strFilter = ""
End If
MSA_CreateFilterString = strFilter
End Function
Function MSA_ConvertFilterString(strFilterIn As String) As String
' 从一个竖条分隔的字符串创建一个过滤字符串。
' 该字符串应具有(过滤名称|扩展名)对，例如，"access 数据库|*.mdb|所有文件|*.*"
' 如果最后一个过滤对没有扩展名，将加上 *.* 。
' 这里代码将忽略任何空字符串，例如， "||" 对。
' 如果传进的字符串是空的，就返回 "" 。
Dim strFilter As String
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strFilter = ""
intNum = 0
intPos = 1
intLastPos = 1
' 一旦我们找到竖条，就加入字符串。
' 忽略任何空字符串(不允许空字符串)。
Do
intPos = InStr(intLastPos, strFilterIn, "|")
If (intPos > intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
intNum = intNum + 1
intLastPos = intPos + 1
ElseIf (intPos = intLastPos) Then
intLastPos = intPos + 1
End If
Loop Until (intPos = 0)
' 获取最后一个子串(假定串 strFilterIn 不以竖条 | 结尾)。
intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
intNum = intNum + 1
End If
' 如果最后一个子串没有扩展名，那么添加 *.* 。
If intNum Mod 2 = 1 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
' 如果存在任何过滤字符串，添加空结尾字符 vbNullChar 。
If strFilter <> "" Then
strFilter = strFilter & vbNullChar
End If
MSA_ConvertFilterString = strFilter
End Function
Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' 打开保存文件对话框。
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_to_OF msaof, of
of.Flags = of.Flags Or OFN_HIDEREADONLY
intRet = GetSaveFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetSaveFileName = intRet
End Function
Function MSA_SimpleGetSaveFileName() As String
' 用默认值打开保存文件对话框。
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetSaveFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetSaveFileName = strRet
End Function
Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' 打开 打开文件对话框。
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_to_OF msaof, of
intRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
End Function
Function MSA_SimpleGetOpenFileName() As String
' 用默认值打开打开文件对话框。
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetOpenFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetOpenFileName = strRet
End Function
Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' 这一个子过程将 win32 结构转换到友好的 MSaccess 结构。
Msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
msaof.strFileNameReturned = of.lpstrFileTitle
msaof.intFileOffset = of.nFileOffset
msaof.intFileExtension = of.nFileExtension
End Sub
Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' 这一个子过程将友好的 MSaccess 结构转换到 win32 结构。
Dim strFile As String * 512
' 初始化该结构的某些部分。
Of.hwndOwner = Application.hWndaccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
If msaof.strFilter = "" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
Else
of.lpstrFilter = msaof.strFilter
End If
of.nFilterIndex = msaof.lngFilterIndex
of.lpstrFile = msaof.strInitialFile _
& String(512 - Len(msaof.strInitialFile), 0)
of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir
of.lpstrDefExt = msaof.strDefaultExtension
of.Flags = msaof.lngFlags
of.lStructSize = Len(of)
End Sub
Public Function CheckLinks() As Boolean
' 检查到后台数据库的链接；如果链接存在且正确的话，返回 True 。
Dim dbs As Database, rst As Recordset
Set dbs = CurrentDb
' 打开链接表查看表链接信息是否正确。
On Error Resume Next
Set rst = dbs.OpenRecordset(CheckTableName)
rst.Close
' 如果没有错误，返回 True 。
If Err = 0 Then
CheckLinks = True
Else
CheckLinks = False
End If
End Function
Private Function RefreshLinks(strFileName As String) As Boolean
' 刷新到提供表的数据库的链接。如果成功的话返回 True 。
Dim dbs As Database
Dim tdf As TableDef
' 循环处理此数据库的所有表。
Set dbs = CurrentDb
For Each tdf In dbs.TableDefs
' 如果表有一个连接串，那么该表是一个链接表。
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & strFileName & ";PWD=" + TablePassword
Err = 0
On Error Resume Next
tdf.RefreshLink ' 重新链接该表。
If Err <> 0 Then
RefreshLinks = False
Exit Function
End If
End If
Next tdf
RefreshLinks = True ' 完成重链接。
End Function
Public Function RelinkTables() As Boolean
' 尝试刷新连到“后台数据库”数据库的链接。
' 如果成功，返回 True 。
Dim strFileName As String
Dim intError As Integer
Dim strError As String
Dim BackDataDir As String
Const conMaxTables = 8
Const conNonExistentTable = 3011
Const conNotNorthwind = 3078
Const conNwindNotFound = 3024
Const conaccessDenied = 3051
Const conReadOnlyDatabase = 3027
'在注册表中读取“后台数据库”的位置
BackDataDir = GetSetting(conAppTitle, conAppTitle, "BackDataDir", "")
If (Dir(BackDataDir & conBackAppTitle) <> "") Then
strFileName = BackDataDir & conBackAppTitle
Else
' 不能找到“后台数据库”，所以显示打开文件对话框。
MsgBox "不能找到“" + conBackAppTitle + "”数据库中的链接表。您必须定位“" + _
conBackAppTitle + "”数据库以便能使用“" _
& conAppTitle & "”数据库程序。", vbExclamation
strFileName = FindFile("C:\", "查找 " + conBackAppTitle, "Microsoft access 数据库", "*.mdb;*.mde")
If Dir(strFileName) = conBackAppTitle Then
BackDataDir = Left(strFileName, Len(strFileName) - Len(conBackAppTitle))
SaveSetting conAppTitle, conAppTitle, "BackDataDir", BackDataDir
Else
strError = "抱歉， 您必须定位“" + conBackAppTitle + "”数据库以打开“" & conAppTitle & "”数据库程序。"
GoTo Exit_Failed
End If
End If
' 修复链接。
If RefreshLinks(strFileName) Then
RelinkTables = True
Exit Function
End If
' 如果失败， 显示一个错误消息。
Select Case Err
Case conNonExistentTable, conNotNorthwind
strError = "文件 '" & strFileName & "' 不包含所要求的数据库表。"
Case Err = conNwindNotFound
strError = "直到您定位了“" + conBackAppTitle + ".mdb”数据库，您不能运行本“" & conAppTitle & "”程序。"
Case Err = conaccessDenied
strError = "因为 " & strFileName & " 是只读的或只读共享的，您不能打开它。"
Case Err = conReadOnlyDatabase
strError = "因为 " & conAppTitle & " 是只读的或只读共享的，您不能重新链接表。"
Case Else
strError = Err.Description
End Select
Exit_Failed:
MsgBox strError, vbCritical
RelinkTables = False
End Function
