Revinculando tabelas ODBC via código

Pessoalmente, acho os passos manuais exigidos para vincular a uma tabela ODBC bastante incômodos. Se você acha o mesmo, aqui está como automatizar o processo.

Autor: Dev Hashish

Sugiro a criação de uma tabela com três campos:

1. LocalTableName - O nome da tabela ODBC como aparece na Janela do Banco de Dados.
2. ConnectString - A string de conexão à tabela ODBC completa (pode ser vista usando ?CurrentDB.TableDefs("SuaTabelaODBC").Connect na janela de depuração.
3. SourceTable - O nome real da tabela ODBC na fonte de dados. Pode ser o mesmo que LocalTableName.

Salve estas informações para todas as tabelas ODBC nesta tabela (chamada de tblReconnectODBC no código). O benefício é que, quando este c&oacut28-Oct-2005 11:25iada a TableDefs para cada registro nesta tabela se os vínculos ODBC não forem encontrados no banco de dados.

Se desejar, acrescente o método RegisterDatabase a este código quando os DSNs não forem encontrados no Registry. Eu, por azar, não tive sorte com isso já que uso Oracle.

'********************* Início do Código ****************************
' Este código foi originalmente escrito por Dev Ashish.
' Ele não deve ser alterado ou distribuído,
' exceto como parte de um aplicativo.
' Use-o livremente em qualquer aplicativo,
' desde que esta nota de copyright não seja alterada.
'
' Código cortesia de 
' Dev Ashish
'
Option Compare Database
Option Explicit

Private Type tODBCInfo
    strTableName As String
    strNewName As String
    strConnectString As String
    strSourceTable As String
End Type

'Contém todas as informações das tabelas
Private mastODBCInfo() As tODBCInfo

'*** Coisas do Registry
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

    'Verifica se todos os DSNs ODBC estão presentes
    'Você pode seguir os mesmos passos para verificar
    'múltiplos DSNs
    strTmp = fReturnRegKeyValue(HKEY_CURRENT_USER, _
                        cREG_PATH & "\qc03", "Server")
    If strTmp = vbNullString Then Err.Raise cERR_NODSN

    'Outro DSN ODBC
    strTmp = fReturnRegKeyValue(HKEY_CURRENT_USER, _
                        cREG_PATH & "\PMIP", "Server")
    If strTmp = vbNullString Then Err.Raise cERR_NODSN


    If MsgBox("Derrubar vínculos ODBC e reconectar?" _
                & vbCrLf & vbCrLf & _
                "As tabelas ODBC vinculadas serão renomeadas " _
                & "e reconectadas. " _
                & vbCrLf & "Se não ocorrerem erros, " _
                & "os vínculos antigos serão excluídos.", _
                vbQuestion + vbYesNo, _
                "Por favor, confirme") = vbYes Then
        Set db = CurrentDb
        intTableCount = 0
        varRet = SysCmd(acSysCmdSetStatus, "Salvando a informação de coneção ODBC.....")

        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

        'Agora tenta revincular
        If Not boolTablesPresent Then
            'Ainda nenhuma tabela ODBC presente
            'reconecta usando as informações contidas na tabela
            strMsg = "Nenhuma tabela ODBC encontrada neste banco de dados." & vbCrLf _
                            & "Deseja reconectar a todas as fontes ODBC " _
                            & "listadas em 'tblReconnectODBC'?"
            If MsgBox(strMsg, vbYesNo + vbQuestion, "Tabelas ODBC não encontradas") = _
                            vbYes Then
                With rs
                    .MoveFirst
                    Do While Not .EOF
                        varRet = SysCmd(acSysCmdSetStatus, "Revinculando '" _
                                            & !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, "Tentando revincular '" _
                                        & .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 "Todas as tabelas ODBC revinculadas com sucesso.", _
                    vbInformation + vbOKOnly, "Sucesso"

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 & "Erro Nº: " & errX.Number & vbCrLf & errX.Description
        Next
        MsgBox strMsg, vbOKOnly + vbExclamation, "Erros ODBC ao revincular"
    Else
        If Err.Number = cERR_NODSN Then
            MsgBox "O DSN do Usuário para as tabelas Oracle não foram encontradas. Por favor " _
                & "verifique o ODBC32 no Painel de Controle.", vbExclamation + vbOKOnly, _
                "Fontes de dados não localizadas"
        Else
            strMsg = "Erro Nº: " & Err.Number & vbCrLf & Err.Description
            MsgBox strMsg, vbOKOnly + vbExclamation, "Erros VBA ao revincular"
        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
    'Abre a chave primeiro
    lngTmp = apiRegOpenKeyEx(lngKeyToGet, _
                strKeyName, 0&, KEY_READ, lnghKey)

    'Tudo em ordem?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError

    lngReserved = 0&
    strClassName = String$(MAXLEN, 0):  lngClassLen = MAXLEN
    'Pega os valores de fronteira
    lngTmp = apiRegQueryInfoKey(lnghKey, strClassName, _
        lngClassLen, lngReserved, lngSubKeys, lngMaxSubKeyLen, _
        lngMaxClassLen, lngValues, lngMaxValueNameLen, _
        lngMaxValueLen, lngSecurity, ftLastWrite)

    'Como está indo?
    If Not (lngTmp = ERROR_SUCCESS) Then Err.Raise lngTmp + vbObjectError

    'Pega os valores da chave
    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

    'Tudo calmo no front oriental?
    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 *********************