自动更新链接表的模块

    刷新表链接                                 '
'                                                              '
'    这个模块包含用于刷新到后台数据库表的链接的函数，如果那    '
'    些表可用的话。改写自罗斯文商贸数据库！这可是宝库！        '
'                                                              '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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