---Soumis par Dev Ashish---
Rétablir les liens de tables ODBC à partir du code.
Personnellement, je trouve que les étapes requises pour rétablir un lien à une table ODBC plutôt abrutissantes. Si vous partagez ce sentiment, voici une façon d'automatiser le processus.
Je suggère de créer une table avec trois champs,
LocalTableName -- Le nom de la table ODBC tel qu'il apparaît dans la fenêtre de la base de données.
ConnectString -- La chaîne complète de connexion à la table ODBC.
(On peut l'examiner en demandant:
?CurrentDB.TableDefs("SomeODBCTable").Connect
SourceTable -- Le nom de la table ODBC dans la source de
données. Peut être le même nom que celui du premier champ.
Conserver cette information pour toutes les tables ODBC dans cette table que
j'appelle tblReconnectODBC
dans le code. Le bénéfice est qu'en exécutant le code dans une
nouvelle base de données, chaque définition de table, tabledef, est recrée
pour chaque enregistrement puisque aucun lien non trouvé.
Si vous le désirez, vous pouvez également ajouter la
méthode RegisterDatabase à ce code sir le DSN n'est pas
trouvé dans le registre du système. Malheureusement, je n'ai pas eu de change
avec ce code puisque je travaille avec Oracle.
'****************** Code Start *********************> ' Option Compare Database Option Explicit Private Type tODBCInfo strTableName As String strNewName As String strConnectString As String strSourceTable As String End Type 'Contains all info for tables Private mastODBCInfo() As tODBCInfo '*** Registry stuff Private Const HKEY_CLASSES_ROOT = &H80000000 Private Const HKEY_CURRENT_USER = &H80000001 Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const HKEY_USERS = &H80000003 Private Const HKEY_PERFORMANCE_DATA = &H80000004 Private Const HKEY_CURRENT_CONFIG = &H80000005 Private Const HKEY_DYN_DATA = &H80000006 Private Const STANDARD_RIGHTS_READ = &H20000 Private Const KEY_QUERY_VALUE = &H1& Private Const KEY_ENUMERATE_SUB_KEYS = &H8& Private Const KEY_NOTIFY = &H10& Private Const Synchronize = &H100000 Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _ KEY_QUERY_VALUE Or _ KEY_ENUMERATE_SUB_KEYS Or _ KEY_NOTIFY) And _ (Not Synchronize)) Private Const MAXLEN = 256 Private Const ERROR_SUCCESS = &H0& Const REG_NONE = 0 Const REG_SZ = 1 Const REG_EXPAND_SZ = 2 Const REG_BINARY = 3 Const REG_DWORD = 4 Const REG_DWORD_LITTLE_ENDIAN = 4 Const REG_DWORD_BIG_ENDIAN = 5 Const REG_LINK = 6 Const REG_MULTI_SZ = 7 Const REG_RESOURCE_LIST = 8 Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Declare Function apiRegOpenKeyEx Lib "advapi32.dll" _ Alias "RegOpenKeyExA" _ (ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As Long) _ As Long Private Declare Function apiRegCloseKey Lib "advapi32.dll" _ Alias "RegCloseKey" _ (ByVal hKey As Long) _ As Long Private Declare Function apiRegQueryValueEx Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ lpData As Any, _ ByRef lpcbData As Long) _ As Long Private Declare Function apiRegQueryInfoKey Lib "advapi32.dll" _ Alias "RegQueryInfoKeyA" _ (ByVal hKey As Long, _ ByVal lpClass As String, _ ByRef lpcbClass As Long, _ ByVal lpReserved As Long, _ ByRef lpcSubKeys As Long, _ ByRef lpcbMaxSubKeyLen As Long, _ ByRef lpcbMaxClassLen As Long, _ ByRef lpcValues As Long, _ ByRef lpcbMaxValueNameLen As Long, _ ByRef lpcbMaxValueLen As Long, _ ByRef lpcbSecurityDescriptor As Long, _ ByRef lpftLastWriteTime As FILETIME) _ As Long Function fReconnectODBC() As Boolean Dim db As Database, tdf As TableDef Dim varRet As Variant, rs As Recordset Dim strConnect As String Dim intTableCount As Integer Dim i As Integer Dim strTmp As String, strMsg As String Dim boolTablesPresent As Boolean Const cERR_NODSN = vbObjectError + 300 Const cREG_PATH = "Software\ODBC\ODBC.INI" On Error GoTo fReconnectODBC_Err 'Check to make sure ODBC DSNs are present 'You can follow the same steps to check for multiple DSNs strTmp = fReturnRegKeyValue(HKEY_CURRENT_USER, _ cREG_PATH & "\qc03", "Server") If strTmp = vbNullString Then Err.Raise cERR_NODSN 'Another ODBC DSN strTmp = fReturnRegKeyValue(HKEY_CURRENT_USER, _ cREG_PATH & "\PMIP", "Server") If strTmp = vbNullString Then Err.Raise cERR_NODSN If MsgBox("Is it ok to drop ODBC links and reconnect?" _ & vbCrLf & vbCrLf & _ "The linked ODBC tables will be renamed " _ & "and then reconnected. " _ & vbCrLf & "If there were no errors encountered, " _ & "then the old tables links will be deleted.", _ vbQuestion + vbYesNo, _ "Please confirm") = vbYes Then Set db = CurrentDb intTableCount = 0 varRet = SysCmd(acSysCmdSetStatus, "Storing ODBC link info.....") Set rs = db.OpenRecordset("tblReconnectODBC", dbOpenSnapshot) boolTablesPresent = False For Each tdf In db.TableDefs strConnect = tdf.Connect If Len(strConnect) > 0 And left$(tdf.Name, 1) <> "~" Then If left$(strConnect, 4) = "ODBC" Then ReDim Preserve mastODBCInfo(intTableCount) With mastODBCInfo(intTableCount) .strTableName = tdf.Name rs.FindFirst "TableName='" & .strTableName & "'" If Not rs.NoMatch Then .strConnectString = rs!ConnectString .strSourceTable = rs!SourceTable Else .strSourceTable = tdf!SourceTableName .strConnectString = tdf!ConnectString End If End With boolTablesPresent = True intTableCount = intTableCount + 1 End If End If Next 'now attempt relink If Not boolTablesPresent Then 'No ODBC Tables present yet 'Reconnect from the table info strMsg = "No ODBC tables were found in this database." & vbCrLf _ & "Do you wish to reconnect to all the ODBC sources " _ & "listed in 'tblReconnectODBC' tables?" If MsgBox(strMsg, vbYesNo + vbQuestion, "ODBC Tables not present") = _ vbYes Then With rs .MoveFirst Do While Not .EOF varRet = SysCmd(acSysCmdSetStatus, "Relinking '" _ & !TableName & "'.....") Set tdf = db.CreateTableDef(!TableName, _ dbAttachSavePWD, _ !SourceTable, _ !ConnectString) db.TableDefs.Append tdf db.TableDefs.Refresh .MoveNext Loop End With End If Else For i = 0 To intTableCount - 1 With mastODBCInfo(i) varRet = SysCmd(acSysCmdSetStatus, "Attempting to relink '" _ & .strTableName & "'.....") strTmp = Format(Now(), "MMDDYY-hhmmss") db.TableDefs(.strTableName).Name = .strTableName & strTmp db.TableDefs.Refresh .strNewName = .strTableName & strTmp Set tdf = db.CreateTableDef(.strTableName, _ dbAttachSavePWD, _ .strSourceTable, _ .strConnectString) db.TableDefs.Append tdf db.TableDefs.Refresh DoCmd.DeleteObject acTable, .strNewName End With Next End If End If varRet = SysCmd(acSysCmdClearStatus) fReconnectODBC = True MsgBox "All ODBC tables were successfully reconnected.", _ vbInformation + vbOKOnly, "Success" fReconnectODBC_Exit: Set tdf = Nothing Set db = Nothing Erase mastODBCInfo Exit Function fReconnectODBC_Err: Dim errX As Error If Errors.Count > 1 Then For Each errX In Errors strMsg = strMsg & "Error #: " & errX.Number & vbCrLf & errX.Description Next MsgBox strMsg, vbOKOnly + vbExclamation, "ODBC Errors in reconnect" Else If Err.Number = cERR_NODSN Then MsgBox "The User DSN for Oracle Tables were not found. Please " _ & "check ODBC32 under Control Panel.", vbExclamation + vbOKOnly, _ "Couldn't locate User Data Sources" Else strMsg = "Error #: " & Err.Number & vbCrLf & Err.Description MsgBox strMsg, vbOKOnly + vbExclamation, "VBA Errors in reconnect" End If End If fReconnectODBC = False Resume fReconnectODBC_Exit End Function Function fReturnRegKeyValue(ByVal lngKeyToGet As Long, _ ByVal strKeyName As String, _ ByVal strValueName As String) _ As String Dim lnghKey As Long Dim strClassName As String Dim lngClassLen As Long Dim lngReserved As Long Dim lngSubKeys As Long Dim lngMaxSubKeyLen As Long Dim lngMaxClassLen As Long Dim lngValues As Long Dim lngMaxValueNameLen As Long Dim lngMaxValueLen As Long Dim lngSecurity As Long Dim ftLastWrite As FILETIME Dim lngType As Long Dim lngData As Long Dim lngTmp As Long Dim strRet As String Dim varRet As Variant Dim lngRet As Long On Error GoTo fReturnRegKeyValue_Err 'Open the key first lngTmp = apiRegOpenKeyEx(lngKeyToGet, _ strKeyName, 0&, KEY_READ, lnghKey) 'Are we ok? If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError lngReserved = 0& strClassName = String$(MAXLEN, 0): lngClassLen = MAXLEN 'Get boundary values lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, _ lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, _ lngMaxClassLen, lngValues, lngMaxValueNameLen, _ lngMaxValueLen, lngSecurity, ftLastWrite) 'How we doin? If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError 'Now grab the value for the key strRet = String$(MAXLEN - 1, 0) lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _ lngReserved, lngType, ByVal strRet, lngData) Select Case lngType Case REG_SZ lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _ lngReserved, lngType, ByVal strRet, lngData) varRet = left(strRet, lngData - 1) Case REG_DWORD lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _ lngReserved, lngType, lngRet, lngData) varRet = lngRet Case REG_BINARY lngTmp = apiRegQueryValueEx(lnghKey, strValueName, _ lngReserved, lngType, ByVal strRet, lngData) varRet = left(strRet, lngData) End Select 'All quiet on the western front? If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError fReturnRegKeyValue_Exit: fReturnRegKeyValue = varRet lngTmp = apiRegCloseKey(lnghKey) Exit Function fReturnRegKeyValue_Err: varRet = vbNullString Resume fReturnRegKeyValue_Exit End Function '****************** Code End *********************