Option Compare Database
Option Explicit

' DWORD GetTempPathW(
'   [in]  DWORD  nBufferLength,
'   [out] LPWSTR lpBuffer
' );
Public Declare PtrSafe Function GetTempPathW _
Lib "kernel32.dll" ( _
    ByVal nBufferLength As Long, _
    ByVal lpBuffer As LongPtr _
) As Long

' int lstrlenW(
'   [in] LPCWSTR lpString
' );
Public Declare PtrSafe Function lstrlenW _
Lib "kernel32.dll" ( _
    ByVal lpString As LongPtr _
) As Long

' Handle Types
Private Const SQL_HANDLE_ENV As Integer = 1
Private Const SQL_HANDLE_DBC As Integer = 2

' Environment Attributes
Private Const SQL_ATTR_ODBC_VERSION As Integer = 200

' ODBC Version
' Access is an ODBC v2 client so best to be compatible with Access.
Private Const SQL_OV_ODBC2 As Long = &H2

' Driver Completion
Private Const SQL_DRIVER_NOPROMPT As Integer = 0
Private Const SQL_DRIVER_COMPLETE As Integer = 1
Private Const SQL_DRIVER_PROMPT As Integer = 2
Private Const SQL_DRIVER_COMPLETE_REQUIRED As Integer = 3

' Return value (SQLRETURN)
Private Const SQL_SUCCESS As Integer = 0
Private Const SQL_SUCCESS_WITH_INFO As Integer = 1
Private Const SQL_NO_DATA As Integer = 100
Private Const SQL_ERROR As Integer = -1
Private Const SQL_INVALID_HANDLE As Integer = -2
Private Const SQL_STILL_EXECUTING As Integer = 2

' Various constants
Private Const SQL_IS_INTEGER As Integer = -6
Private Const SQL_NULL_HANDLE As Integer = 0
Private Const SQL_FETCH_NEXT As Integer = 1
Private Const SQL_FETCH_FIRST As Integer = 2

' SQLRETURN SQLAllocHandle(
'       SQLSMALLINT   HandleType,
'       SQLHANDLE     InputHandle,
'       SQLHANDLE *   OutputHandlePtr);
Private Declare PtrSafe Function SQLAllocHandle _
Lib "odbc32.dll" ( _
    ByVal HandleType As Integer, _
    ByVal InputHandle As LongPtr, _
    ByRef OutputHandlePtr As LongPtr _
) As Integer

' SQLRETURN SQLSetEnvAttr(
'      SQLHENV      EnvironmentHandle,
'      SQLINTEGER   Attribute,
'      SQLPOINTER   ValuePtr,
'      SQLINTEGER   StringLength);
Private Declare PtrSafe Function SQLSetEnvAttr _
Lib "odbc32.dll" ( _
    ByVal EnvironmentHandle As LongPtr, _
    ByVal EnvAttribute As Integer, _
    ByVal ValuePtr As LongPtr, _
    ByVal StringLength As Integer _
) As Integer

' SQLRETURN SQLFreeHandle(
'      SQLSMALLINT   HandleType,
'      SQLHANDLE     Handle);
Private Declare PtrSafe Function SQLFreeHandle _
Lib "odbc32.dll" ( _
    ByVal HandleType As Integer, _
    ByVal Handle As LongPtr _
) As Integer

' SQLRETURN SQLDriverConnect(
'      SQLHDBC         ConnectionHandle,
'      SQLHWND         WindowHandle,
'      SQLCHAR *       InConnectionString,
'      SQLSMALLINT     StringLength1,
'      SQLCHAR *       OutConnectionString,
'      SQLSMALLINT     BufferLength,
'      SQLSMALLINT *   StringLength2Ptr,
'      SQLUSMALLINT    DriverCompletion);
Private Declare PtrSafe Function SQLDriverConnect _
Lib "odbc32.dll" ( _
    ByVal ConnectionHandle As LongPtr, _
    ByVal WindowHandle As LongPtr, _
    ByVal InConnectionString As String, _
    ByVal StringLength1 As Integer, _
    ByVal OutConnectionString As String, _
    ByVal BufferLength As Integer, _
    ByRef StringLength2Ptr As Integer, _
    ByVal DriverCompletion As Integer _
) As Integer

' SQLRETURN SQLBrowseConnect(
'      SQLHDBC         ConnectionHandle,
'      SQLCHAR *       InConnectionString,
'      SQLSMALLINT     StringLength1,
'      SQLCHAR *       OutConnectionString,
'      SQLSMALLINT     BufferLength,
'      SQLSMALLINT *   StringLength2Ptr);
Private Declare PtrSafe Function SQLBrowseConnect _
Lib "odbc32.dll" ( _
    ByVal ConnectionHandle As LongPtr, _
    ByVal InConnectionString As String, _
    ByVal StringLength1 As Integer, _
    ByVal OutConnectionString As String, _
    ByVal BufferLength As Integer, _
    ByRef StringLength2Ptr As Integer _
) As Integer

' SQLRETURN SQLDisconnect(
'      SQLHDBC     ConnectionHandle);
Private Declare PtrSafe Function SQLDisconnect _
Lib "odbc32.dll" ( _
    ByVal ConnectionHandle As LongPtr _
) As Integer

' SQLRETURN SQLDrivers(
'      SQLHENV         EnvironmentHandle,
'      SQLUSMALLINT    Direction,
'      SQLCHAR *       DriverDescription,
'      SQLSMALLINT     BufferLength1,
'      SQLSMALLINT *   DescriptionLengthPtr,
'      SQLCHAR *       DriverAttributes,
'      SQLSMALLINT     BufferLength2,
'      SQLSMALLINT *   AttributesLengthPtr);
Private Declare PtrSafe Function SQLDrivers _
Lib "odbc32.dll" ( _
    ByVal EnvironmentHandle As LongPtr, _
    ByVal Direction As Integer, _
    ByVal DriverDescription As String, _
    ByVal BufferLength1 As Integer, _
    DescriptionLengthPtr As Integer, _
    ByVal DriverAttributes As String, _
    ByVal BufferLength2 As Integer, _
    AttributesLengthPtr As Integer _
) As Integer

' SQLRETURN SQLGetDiagRec(
'      SQLSMALLINT     HandleType,
'      SQLHANDLE       Handle,
'      SQLSMALLINT     RecNumber,
'      SQLCHAR *       SQLState,
'      SQLINTEGER *    NativeErrorPtr,
'      SQLCHAR *       MessageText,
'      SQLSMALLINT     BufferLength,
'      SQLSMALLINT *   TextLengthPtr);
Private Declare PtrSafe Function SQLGetDiagRec _
Lib "odbc32.dll" ( _
    ByVal HandleType As Integer, _
    ByVal Handle As LongPtr, _
    ByVal RecNumber As Integer, _
    ByVal SQLState As String, _
    ByRef NativeErrorPtr As Integer, _
    ByVal MessageText As String, _
    ByVal BufferLength As Integer, _
    ByRef TextLengthPtr As Integer _
) As Integer

Private Function SqlFailed(ReturnCode As Integer) As Boolean
    ' ODBC API has only 2 success return code:
    ' SQL_SUCCESS = 0
    ' SQL_SUCCESS_WITH_INFO = 1
    ' Anything other than those 2 values is technically a failure.
    
    SqlFailed = ((ReturnCode And (Not 1)) <> 0)
    If SqlFailed Then
        ' SQL_NO_DATA (100) is considered failure in the sense there was no data returned
        ' so we want to make a distinction of this compared to other failures since it
        ' could be a result of user's cancellation and thus not what one might call a
        ' failure.
        If ReturnCode <> SQL_NO_DATA Then
            Debug.Print "Failed: Return code was " & ReturnCode
        End If
    End If
End Function

Public Function BuildOleDbConnection( _
    Optional InConnectionString As String = vbNullString, _
    Optional hWnd As LongPtr = 0 _
) As String
    Dim DataLinks As Object 'MSDASC.DataLinks
    Dim TempConnection As ADODB.Connection
    Dim Result As Boolean
    
    ' This avoids needing to reference the MSDASC library. If you want to refer to it
    ' for early binding, it is usually found in %CommonProgramFiles%\System\Ole DB\oledb32.dll
    ' and has GUID of {2206CEB0-19C1-11D1-89E0-00C04FD7A829}. In the references dialog,
    ' it is referred to as "Microsoft OLE DB Service Component 1.0 Type Library".
    Set DataLinks = CreateObject("DataLinks")
    
    If hWnd Then
        ' This will center the dialogs from the DataLinks object over the provided hWnd. Useful
        ' for Access popup forms.
        DataLinks.hWnd = hWnd
    Else
        ' This ensures that the dialogs that the DataLinks object open will be associated with
        ' the application. If this is not populated, it may end up being hidden by other windows.
        DataLinks.hWnd = Application.hWndAccessApp
    End If
    
    If Len(InConnectionString) = 0 Then
        Set TempConnection = DataLinks.PromptNew
        ' Check whether the user cancelled out from the dialog.
        Result = Not TempConnection Is Nothing
    Else
        Set TempConnection = New ADODB.Connection
        TempConnection.ConnectionString = InConnectionString
        ' Check whether the user cancelled. If it was cancelled, the TempConneciton will be unmodified.
        Result = DataLinks.PromptEdit(TempConnection)
    End If
    
    If Result Then
        ' Proceed only if we have a new connection string and the user didn't cancel out.
        
        Dim SanitizedString As String
        Dim OriginalPosition As Long
        Dim NewPosition As Long
        Dim NextDelimiterPosition As Long
        Dim KeyValuePair As String
        
        If Len(TempConnection.ConnectionString) Then
            OriginalPosition = 1
            NewPosition = 1
            
            ' Since a sanitized string will be at most as long as the original connection string, it's
            ' sufficient to allocate it the same size as the original connection string.
            SanitizedString = Space$(Len(TempConnection.ConnectionString))
            NextDelimiterPosition = InStr(OriginalPosition, TempConnection.ConnectionString, ";", vbTextCompare)
            Do Until NextDelimiterPosition = 0
                KeyValuePair = Mid$(TempConnection.ConnectionString, OriginalPosition, (NextDelimiterPosition - OriginalPosition) + 1)
                ' Check if the key-value pair is an empty pair; it will always end with `="";`. We want to remove them
                ' to ensure the providers do not attempt to incorrectly initialize nonsense that users didn't explicitly
                ' request when creating the connection string.
                If Right$(KeyValuePair, 4) = "="""";" Then
                    ' Skip
                Else
                    Mid$(SanitizedString, NewPosition, Len(KeyValuePair)) = KeyValuePair
                    NewPosition = NewPosition + Len(KeyValuePair)
                End If
                
                OriginalPosition = OriginalPosition + Len(KeyValuePair)
                NextDelimiterPosition = InStr(OriginalPosition, TempConnection.ConnectionString, ";", vbTextCompare)
            Loop
        End If
        BuildOleDbConnection = Trim$(SanitizedString)
    Else
        ' Since the user cancelled out, return the original connection string
        BuildOleDbConnection = InConnectionString
    End If
End Function

Public Function BuildOdbcConnectionString( _
    DriverName As String, _
    Optional ByVal hWnd As LongPtr = 0 _
) As String
    Dim HandleEnv As LongPtr
    Dim HandleDbc As LongPtr
    Dim InConnectionString As String
    Dim OutConnectionString As String
    Dim OutLength As Integer
    Dim TempDsn As String
    Dim PathLength As Long

    ' ODBC API mandates that the dialogs be associated to a parent hWnd. We'll use Application's window handle
    ' as a fallback. For more control, we can pass in a form's hWnd instead.
    If hWnd = 0 Then
        hWnd = Application.hWndAccessApp
    End If
    
    ' Build a path to the temporary DSN in the temporary folder
    TempDsn = Space$(261)
    PathLength = GetTempPathW(Len(TempDsn), StrPtr(TempDsn))
    If PathLength Then
        TempDsn = Left$(TempDsn, PathLength) & "Temp.dsn"
    End If
    
    If SqlFailed(SQLAllocHandle(SQL_HANDLE_ENV, &H0&, HandleEnv)) Then
        GoTo ExitProc
    End If

    ' Because Access is a v2 ODBC client, it's best to set up the environment using ODBC v2
    If SqlFailed(SQLSetEnvAttr(HandleEnv, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC2, SQL_IS_INTEGER)) Then
        GoTo ExitProc
    End If

    If SqlFailed(SQLAllocHandle(SQL_HANDLE_DBC, HandleEnv, HandleDbc)) Then
        GoTo ExitProc
    End If

    ' Ensure no prior file is present at the path. If it is present ODBC API will attempt
    ' to read the content of the file which may cause undefined behaviors.
    On Error Resume Next
    Kill TempDsn
    On Error GoTo 0

    ' Validate it does not in fact exist.
    If Len(Dir(TempDsn, vbDirectory)) Then
        Err.Raise 55, , "The temporary DSN file at '" & TempDsn & "' could not be deleted. It may be in use. It must be deleted in order for the BuildOdbcConnectionString to function."
        GoTo ExitProc
    End If
    
    ' By setting both SAVEFILE and DRIVER we effectively instruct the ODBC API to bypass
    ' the DSN selection screens and go directly to the driver's configuration dialogs.
    InConnectionString = "SAVEFILE=" & TempDsn & ";DRIVER=" & DriverName & ";"
    OutLength = 1024 ' Per ODBC API documentation, this should be how much we should allocate.
    OutConnectionString = Space$(OutLength)
    
    If SqlFailed(SQLDriverConnect(HandleDbc, hWnd, InConnectionString, Len(InConnectionString), OutConnectionString, Len(OutConnectionString), OutLength, SQL_DRIVER_PROMPT)) Then
        ' ATtempt to get more detailed error for the failure to get the connection string.
        Dim SqlStateText As String
        SqlStateText = Space$(25)
        Dim NativeError As Integer
        OutLength = 1024
        Dim MessageText As String
        MessageText = Space$(OutLength)
        
        Dim ErrorNumber As Integer
        Dim ErrorMessage As String
        ErrorNumber = SQLGetDiagRec(SQL_HANDLE_DBC, HandleDbc, 1, SqlStateText, NativeError, MessageText, OutLength, OutLength)
        ' SQL_NO_DATA indicates that the user cancelled out of the dialogs and thus is not an error arising from the programming.
        If ErrorNumber <> SQL_NO_DATA Then
            ErrorMessage = Trim$(SqlStateText) & vbNewLine & NativeError & vbNewLine & Trim$(MessageText)
            Err.Raise vbObjectError + ErrorNumber, "BuildOdbcConnectionString", ErrorMessage
        End If
        GoTo ExitProc
    End If

    ' Calling SQLDriverConnect successfully causes the handle to be in a connected state, so we must
    ' disconnect the handle for proper clean-up.
    If SqlFailed(SQLDisconnect(HandleDbc)) Then
        GoTo ExitProc
    End If

    BuildOdbcConnectionString = Left$(OutConnectionString, OutLength)

ExitProc:
    On Error Resume Next
    ' Release all opened handles. After releasing, we set them to 0 out of abundance of caution since
    ' referencing them after release would be a bad thing™.
    If HandleDbc Then
        If SqlFailed(SQLFreeHandle(SQL_HANDLE_DBC, HandleDbc)) Then
            Debug.Print "Memory may have leaked: HandleDbc", HandleEnv
        Else
            HandleDbc = 0
        End If
    End If
    If HandleEnv Then
        If SqlFailed(SQLFreeHandle(SQL_HANDLE_ENV, HandleEnv)) Then
            Debug.Print "Memory may have leaked: HandleEnv", HandleEnv
        Else
            HandleEnv = 0
        End If
    End If
    ' Delete the temporary DSN file. We don't need it hanging around after getting the connection string.
    Kill TempDsn
    On Error GoTo 0
End Function

Public Function EnumerateODBCDrivers() As ADODB.Recordset
    ' The function returns more details about the drivers, including its attributes as an ADODB.Recordset object
    ' to support scenarios where one might want to inspect and get more information about each driver.
    
    Dim ReturnCode As Integer
    Dim SQLHandle As LongPtr
    Dim DriverDescription As String
    Dim DriverAttribute As String
    Dim DriverDescriptionLength As Integer
    Dim AttributesLength As Integer
    Dim Result As ADODB.Recordset
    
    ' Set up a disconnected in-memory recordset.
    ' Description is essentially driver's name
    ' Attributes is a delimited string using colons as a separator.
    Set Result = New ADODB.Recordset
    Result.Fields.Append "Description", adVarWChar, 255, adFldKeyColumn Or adFldRowID
    Result.Fields.Append "Attributes", adLongVarWChar, 8000, adFldIsNullable Or adFldMayBeNull
    Result.Open
    
    Const BufferSize As Long = 2048

    If SqlFailed(SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, SQLHandle)) Then
        GoTo ExitProc
    End If

    ' Because Access is a v2 ODBC client, it's best to set up the environment using ODBC v2.
    If SqlFailed(SQLSetEnvAttr(SQLHandle, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC2, SQL_IS_INTEGER)) Then
        GoTo ExitProc
    End If

    ' We must initialize the temporary buffers.
    DriverDescription = Space$(BufferSize)
    DriverAttribute = Space$(BufferSize)

    ' Before entering the loop, we'll fetch the first driver to initialize the buffers.
    ReturnCode = SQLDrivers(SQLHandle, _
        SQL_FETCH_FIRST, _
        DriverDescription, _
        Len(DriverDescription), _
        DriverDescriptionLength, _
        DriverAttribute, _
        Len(DriverAttribute), _
        AttributesLength _
    )

    Do While ReturnCode = SQL_SUCCESS
        ' Replace NULL separators with colons in attribute string
        If AttributesLength Then
            DriverAttribute = Left$(DriverAttribute, AttributesLength - 1)
            DriverAttribute = Replace(DriverAttribute, vbNullChar, " : ")
        Else
            DriverAttribute = vbNullString
        End If

        ' Remove NULL in ODBC Driver name
        If DriverDescriptionLength Then
            DriverDescription = Left$(DriverDescription, DriverDescriptionLength)
            DriverDescription = Replace(DriverDescription, vbNullChar, vbNullString)
        Else
            DriverDescription = vbNullString
        End If
        
        ' Add a new entry to the in-memory recordset for the driver.
        Result.AddNew
        Result.Fields("Description").Value = DriverDescription
        Result.Fields("Attributes").Value = DriverAttribute
        Result.Update
        
        ' Clear the temporary buffer for the next iteration.
        DriverDescription = Space$(BufferSize)
        DriverAttribute = Space$(BufferSize)

        ' Fetch the next driver.
        ReturnCode = SQLDrivers(SQLHandle, _
            SQL_FETCH_NEXT, _
            DriverDescription, _
            Len(DriverDescription), _
            DriverDescriptionLength, _
            DriverAttribute, _
            Len(DriverAttribute), _
            AttributesLength _
        )
    Loop

    ' Move the cursor on the recordset to first record before returning the recordset.
    If Not Result.State = adStateClosed Then
        If (Not Result.BOF) And (Not Result.EOF) Then
            Result.MoveFirst
        End If
    End If
    Set EnumerateODBCDrivers = Result

ExitProc:
    If SQLHandle Then
        ReturnCode = SQLFreeHandle(SQL_HANDLE_ENV, SQLHandle)
    End If
End Function

Public Function EnumerateODBCDriverNamesCSV() As String
    ' The function returns only the driver names in a semicolon delimited comma, which is convenient
    ' for using in a combobox's or a listbox's RowSource.
    
    Dim Buffer As String
    Dim Position As Long
    Dim Length As Long
    
    Dim ReturnCode As Integer
    Dim SQLHandle As LongPtr
    Dim DriverDescription As String
    Dim DriverDescriptionLength As Integer
    Dim AttributesLength As Integer
    
    Const BufferSize As Long = 2048

    ' Set up the position and allocate large enough buffer to hold approximately 32 drivers
    ' and thus avoid reallocating the buffer. I doubt there are any computers with so many
    ' ODBC drivers installed.... right? Note that by default, Windows will ship with a number
    ' of ODBC drivers as part of MDAC/WDAC package, and there would be approximately 5 drivers.
    Position = 1
    Buffer = String$(BufferSize * 32, vbNullChar)
    
    If SqlFailed(SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, SQLHandle)) Then
        GoTo ExitProc
    End If

    ' Because Access is a v2 ODBC client, it's best to set up the environment using ODBC v2.
    If SqlFailed(SQLSetEnvAttr(SQLHandle, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC2, SQL_IS_INTEGER)) Then
        GoTo ExitProc
    End If

    ' Set up the temporary buffers.
    DriverDescription = Space$(BufferSize)
    
    ' Before entering the loop, fetch the first driver and populate the temporary buffers.
    ReturnCode = SQLDrivers(SQLHandle, _
        SQL_FETCH_FIRST, _
        DriverDescription, _
        Len(DriverDescription), _
        DriverDescriptionLength, _
        vbNullString, _
        0, _
        AttributesLength _
    )

    Do While ReturnCode = SQL_SUCCESS
        ' Remove NULL in ODBC Driver name.
        If DriverDescriptionLength Then
            DriverDescription = Left$(DriverDescription, DriverDescriptionLength)
            DriverDescription = Replace(DriverDescription, vbNullChar, vbNullString)
        Else
            DriverDescription = vbNullString
        End If
        
        ' Include the space for the semicolon separator
        Length = Len(DriverDescription) + 1
        
        ' Check if the buffer still has enough space or if we need to reallocate it.
        If (Position + Length) > (Len(Buffer)) Then
            Buffer = Buffer & String$(Len(Buffer), vbNullChar)
        End If
        
        ' Insert the driver's name in the buffer and advance the position with a new semicolon separator.
        Mid$(Buffer, Position, Length) = DriverDescription & ";"
        Position = Position + Length
        
        ' Clear the temporary buffer for the next iteration.
        DriverDescription = Space$(BufferSize)
        
        ' Fetch the next driver
        ReturnCode = SQLDrivers(SQLHandle, _
            SQL_FETCH_NEXT, _
            DriverDescription, _
            Len(DriverDescription), _
            DriverDescriptionLength, _
            vbNullString, _
            0, _
            AttributesLength _
        )
    Loop
    
    ' Return only the filled buffer.
    EnumerateODBCDriverNamesCSV = Left$(Buffer, Position - 1)

ExitProc:
    If SQLHandle Then
        ReturnCode = SQLFreeHandle(SQL_HANDLE_ENV, SQLHandle)
    End If
End Function