Auf Access oder einer Jet-Datenbank basierende Programme arbeiten nach Upgrade von Windows NT 4.0 auf Windows 2000 oder Windows XP langsamer

Declare Function GetShortPathName Lib "kernel32" _
            Alias "GetShortPathNameA" (ByVal lpszLongPath As String, _
           ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Function RefreshLinks()
    On Error GoTo ErrorHandler
    
    'Define the ADOX Catalog object.
    Dim objCat As New ADOX.Catalog 
    'Define the ADOX Table object.
    Dim objTbl As ADOX.Table 

    'Database name of the linked table.
    Dim strFilename As String 
    'Path and database name of the linked table.
    Dim strFullName As String 

    Dim blnIsMapi As Boolean
    Dim blnIsImex As Boolean
    Dim blnIsTemp As Boolean
    Dim blnLongFileName As Boolean
    Dim blnFailedLink As Boolean
    Const srtImex = "IMEX"
    Const strMapi = "MAPILEVEL="

    'Open the catalog.
    objCat.ActiveConnection = CurrentProject.Connection

    'Loop through the table collection and update the linked tables.
    For Each objTbl In objCat.Tables
        'Verify that the table is a linked table.
        If objTbl.Type = "LINK" = True Then
            blnIsTemp = objTbl.Properties("Temporary Table") Or Left(objTbl.Name, 1) = "~"
            blnIsImex = (InStr(1, objTbl.Properties("Jet OLEDB:Link Provider String"), srtImex, vbTextCompare) > 0)
            blnIsMapi = (InStr(1, objTbl.Properties("Jet OLEDB:Link Provider String"), strMapi, vbTextCompare) > 0)

            If Not blnIsTemp And Not blnIsImex And Not blnIsMapi Then  
                'Verify that the table is a Jet table.
                strFullName = objTbl.Properties("Jet OLEDB:Link Datasource")
                strFilename = Mid(strFullName, InStrRev(strFullName, "\", _
                            Len(strFullName)) + 1, Len(strFullName))
                'Determine whether the database exists.
                If DoesFileExist(strFullName) = True Then
                    objTbl.Properties("Jet OLEDB:Link Datasource") = GetShortName(strFullName)  
                'Update the link by using the short path name.
                Else
                    MsgBox "Cannot update: '" & objTbl.Name & "'" & String(2, vbCrLf) & "File not found: " & vbCrLf & strFullName
                    blnFailedLink = True
                End If
                If InStr(strFilename, ".") > 9 Then blnLongFileName = True
            End If
        End If
    Next
   
    If blnFailedLink = False Then
        If blnLongFileName = True Then
            MsgBox "The table links were successfully updated, but the name of the backend database file does not follow 8.3" & _
            vbCrLf & "Please rename the file, relink the tables, and then run the procedure again.", vbExclamation
        Else
            MsgBox "The links were successfully updated!!! ", vbInformation
        End If
    Else
        MsgBox "The links were not successfully updated." & vbCrLf & "Please verify you table links.", vbExclamation
    End If

ExitHandler:
     Exit Function

ErrorHandler:
    MsgBox Err.Description & " " & Err.Number
    Resume ExitHandler
    
End Function
Function GetShortName(ByVal sLongFileName As String) As String
           Dim lRetVal As Long, sShortPathName As String, iLen As Integer
           'Set up a buffer area for the API function call return.
           sShortPathName = Space(255)
           iLen = Len(sShortPathName)
    
           'Call the function.
           lRetVal = GetShortPathName(sLongFileName, sShortPathName, iLen)
           'Remove unwanted characters.
           GetShortName = Left(sShortPathName, lRetVal)
 End Function

Function DoesFileExist(strFileSpec As String) As Boolean
    'Return True if the file that is specified in the
    'strFilespec argument exists.
    'Return False if strFileSpec is not a valid
    'file or if strFileSpec is a directory.
    Const INVALID_ARGUMENT As Long = 53
    On Error GoTo DoesfileExist_Err
    If (GetAttr(strFileSpec) And vbDirectory) <> vbDirectory Then
        DoesFileExist = CBool(Len(Dir(strFileSpec)) > 0)
    Else
        DoesFileExist = False
    End If
DoesfileExist_End:
    Exit Function
DoesfileExist_Err:
    DoesFileExist = False
    Resume DoesfileExist_End
End Function