locked
Make ODBC DSN 64 bit RRS feed

  • Question

  • I am using the (bottom code) code to change the path to the DSN for text files  (I have hardcoded here)

    This fails when running on a 64 bit machine.   

    I found this code , but it gives no response, and does not create the DSN.

    Thanks

    Adam

         

    *** 64 bit code that does not work


    Private Declare PtrSafe Function SQLConfigDataSource Lib "ODBCCP32" _
        (ByValhwndParent As Long, _
        ByVal fRequest As Long, _
        ByVal lpszDriver As String, _
        ByVal lpszAttributes As String) As Long
    Private Const ODBC_ADD_SYS_DSN = 4
    Private Const ODBC_REMOVE_SYS_DSN = 6
    Sub xx()

    Dim R_REMOVE As LongPtr
    Dim R_ADD As LongPtr
    Dim lpszDriver As String
    Dim lpszAttributes As String

     sDriver = "Microsoft Access Text Driver (*.txt; *.csv)"
    '                    sfile = Sheets("Sheet1").Range("C1") '"C:\REVPPT\SourceData\DataToReport\"


    lpszDriver = "Microsoft Access Text Driver (*.txt; *.csv)" '"Microsoft Access Driver (*.mdb, *.accdb)"
    lpszAttributes = "DSN=DataToReport" + vbNullChar & _
            "Description=YYY" + vbNullChar & _
            "DBQ=C:\\Test\\" + vbNullChar + vbNullChar
    R_REMOVE = SQLConfigDataSource(0, ODBC_REMOVE_SYS_DSN, lpszDriver, lpszAttributes)
    R_ADD = SQLConfigDataSource(0, ODBC_ADD_SYS_DSN, lpszDriver, lpszAttributes)


    End Sub

    *** 32 bit code that works 


    ' Registry API functions
    Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal _
    hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, _
    ByVal lpszAttributes As String) As Long 
    Private Declare Function RegOpenKeyEx Lib "advapi32" 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 RegQueryValueEx Lib "advapi32" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, _
    ByRef lpcbData As Long) As Long
    Const ODBC_ADD_DSN = 1      ' Add data source
    Const ODBC_REMOVE_DSN = 3   ' Delete data source

    Sub SetDsn 
    'Provider=MSDASQL;Persist Security Info=False;DSN=TextDataToReport
      sDriver = "Microsoft Text Driver (*.txt; *.csv)"
                        sfile = "C:\Test\" 
                        sname = "TextDataToReport"
                        MakeDSN sname, sDriver, sfile, ODBC_REMOVE_DSN
                        MakeDSN sname, sDriver, sfile, ODBC_ADD_DSN
    End Sub
    Sub MakeDSN(ByVal sDSN As String, ByVal sDriver As String, _
        ByVal sDBFile As String, ByVal lAction As Long)
        
        Dim sAttributes As String
        Dim sDBQ As String
        Dim lngRet As Long
        
        Dim hKey As Long
        Dim regValue As String
        Dim valueType As Long
        
        ' query the Registry to check whether the DSN is already installed
        ' open the key
        If RegOpenKeyEx(HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI\" & sDSN, 0, _
            KEY_ALL_ACCESS, hKey) = 0 Then
            ' zero means no error => Retrieve value of "DBQ" key
            regValue = String$(1024, 0)
            ' Allocate Variable Space
            If RegQueryValueEx(hKey, "DBQ", 0, valueType, regValue, _
                Len(regValue)) = 0 Then
                ' zero means OK, so we can retrieve the value
                If valueType = REG_SZ Then
                    sDBQ = Left$(regValue, InStr(regValue, vbNullChar) - 1)
                End If
            End If
            ' close the key
            RegCloseKey hKey
        End If
        
        ' Perform the action only if we're adding a DSN that doesn't exist
        ' or removing and existing DSN
        If (sDBQ = "" And lAction = ODBC_ADD_DSN) Or (sDBQ <> "" And lAction = _
            ODBC_REMOVE_DSN) Then
            
            ' check that the file actually exists
            If Len(Dir$(sDBFile)) = 0 Then
                MsgBox "Please check the path name, """ & sDBFile & """ doesn't exist!", vbOKOnly + vbCritical
                Sheets("Setup").Range("S5") = False
                Exit Sub
            End If
            Sheets("Setup").Range("S5") = True
            sAttributes = "DSN=" & sDSN & vbNullChar & "DBQ=" & sDBFile & vbNullChar
            lngRet = SQLConfigDataSource(0&, lAction, sDriver, sAttributes)
        End If
    End Sub

    Adam

    Wednesday, July 29, 2020 8:36 PM