Question

我有一个链接到6个表的访问数据库。这些表每周更新一次，并保存在包含日期的文件夹中。我希望我的访问程序要求用户选择表格的位置，而不是使用链接表格管理器。

Answer 1

以下代码将提示用户输入要链接到的数据库的完整路径和文件名。我决定这样做而不只是提示输入一个文件夹。我强烈建议您查看一个链接表的连接字符串，并确保没有指定其他参数，除了＆＃39 ;; DATABASE = C：\ Foldera \ YYMMDD \ MyAccessDB.mdb＆＃34;

Private Function ReLinkTables()
Dim dbs             As DAO.Database
Dim tdf             As DAO.TableDef
Dim tdf2            As DAO.TableDef
Dim strConn         As String
Dim strNewPath      As String
Dim strTableName    As String

    On Error GoTo ERROR_HANDLER

    ' Prompt user for new path...
    strNewPath = GetFolder

    ' Exit if none
    If strNewPath = "" Then
        Exit Function
    End If

    Set dbs = CurrentDb
    dbs.TableDefs.Refresh
    ' Find all the linked tables...
    For Each tdf In dbs.TableDefs
        'Debug.Print tdf.Name & vbTab & tdf.Connect
        If Len(tdf.Connect) > 0 Then
            strTableName = tdf.Name
            Debug.Print "Linked Table: " & tdf.Name & vbTab & tdf.Connect

            dbs.TableDefs.Delete strTableName         ' Delete the linked table

            strConn = ";DATABASE=" & strNewPath
            Set tdf2 = CurrentDb.CreateTableDef(strTableName, dbAttachSavePWD, strTableName, strConn)
            CurrentDb.TableDefs.Append tdf2
        Else        ' Not a linked table
            'Debug.Print "Keep:    " & tdf.Name & vbTab & tdf.Connect
        End If
    Next tdf

    Set tdf = Nothing
    Set tdf2 = Nothing
    dbs.TableDefs.Refresh
    dbs.Close
    Set dbs = Nothing
    MsgBox "Finished Relinking Tables"
Proc_Exit:

    Exit Function

ERROR_HANDLER:
    Debug.Print Err.Number & vbTab & Err.Description
    Err.Source = "Module_Load_SQLSERVER_DATABASE: ReLinkTables  at Line: " & Erl
    If Err.Number = 9999 Then
        Resume Next
    End If
    MsgBox Err.Number & vbCrLf & Err.Description
    Resume Proc_Exit
    Resume Next
End Function

Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFilePicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        '.InitialFileName = "Z:\xxxxxxxx"           ' You can change to valid start path
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    Debug.Print "User selected path: >" & sItem & "<"
    If sItem = "" Then MsgBox "User did not select a path.", vbOKOnly, "No Path"
    GetFolder = sItem
    Set fldr = Nothing
End Function

链接Access中的表

1 个答案: