Excel

Option Explicit

Private Enum ConnectionType
    MSAccess = 0
    Sybase = 1
End Enum

Private liveConnections As Collection


Private Sub AddLiveConnection 
    (
    ByVal key As String, 
    ByRef theConnection As adodb.connection
    )
    Call CheckLiveConnections
    If Trim(key) <> "" _
            And Not (theConnection Is Nothing) _
            And LiveConnectionExists(key) = False _
            And theConnection.State = adodb.adStateOpen _
            Then
        liveConnections.Add theConnection, key
    End If
End Sub

Private Function GetLiveConnection(ByVal key As String) As adodb.connection
    CheckLiveConnections
    If CollectionItemExists(liveConnections, key) Then
        Set GetLiveConnection = liveConnections(key)
    Else
        Set GetLiveConnection = Nothing
    End If
End Function

Private Function LiveConnectionExists(ByVal key As String) As Boolean
    Dim db As adodb.connection
    
    Call CheckLiveConnections
    If CollectionItemExists(liveConnections, key) Then
        Set db = liveConnections(key)
        If db.State = adStateOpen Then
            LiveConnectionExists = True
        Else
            'The connection must have existed, but was not open, so delete it.
            Set db = Nothing
            liveConnections.Remove (key)
        End If
    End If
End Function

Private Sub CheckLiveConnections()
    'Need to check that the liveConnections array exists, as it may have died previously.
    If liveConnections Is Nothing Then
        Set liveConnections = New Collection
    End If
End Sub

Private Function GetDBConnection
    (
    ByVal connType As ConnectionType, 
    ByVal info As String
    ) As adodb.connection
    Dim odbcStr As String
    
    On Error GoTo ErrorHandler
    
    'Open a connection to the database
    Set GetDBConnection = New adodb.connection
    
    Select Case connType
        Case ConnectionType.MSAccess
            'For access databases the info is the file path of the database
            odbcStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=""" & info & """"
        Case ConnectionType.Sybase
            'For Sybase databases the info is the odbc string
            odbcStr = info & "Driver={SYBASE ASE ODBC Driver};"
    End Select
    
    GetDBConnection.ConnectionString = odbcStr
    GetDBConnection.Open
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function

Public Function OpenConnection_Access(ByVal pathMDB As String) As adodb.connection
    On Error GoTo ErrorHandler
    
    Set OpenConnection_Access = GetDBConnection(MSAccess, pathMDB)
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function

Public Function OpenConnection_ODBC
    (
    ByVal server As String, 
    ByVal db As String, 
    ByVal user As String, 
    ByVal password As String
    ) As adodb.connection
    On Error GoTo ErrorHandler
    
    Dim odbcString As String
    Dim key As String

    'Build the key for the collection
    key = server & "_" & db & "_" & user
    
    'Return the connection if it exists already
    If LiveConnectionExists(key) Then
        Set OpenConnection_ODBC = GetLiveConnection(key)
    Else
        odbcString = odbcString & "Srvr=" & server & ";"
        odbcString = odbcString & "Database=" & db & ";"
        odbcString = odbcString & "Pwd=" & password & ";"
        odbcString = odbcString & "uid=" & user & ";"
        Set OpenConnection_ODBC = GetDBConnection(Sybase, odbcString)
        Call AddLiveConnection(key, OpenConnection_ODBC)
    End If
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function



Public Sub CloseDBConnection(ByRef dbConn As adodb.connection)

    On Error GoTo ErrorHandler
    
    'If there is a connection shut it down.
    If Not (dbConn Is Nothing) Then
        If dbConn.State = adodb.adStateOpen Then
            dbConn.Close
        End If
        Set dbConn = Nothing
    End If
    
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description
    
End Sub

Private Function SQLRecordset
    (
    ByRef dbConn As adodb.connection, 
    ByVal sql As String
    ) As adodb.Recordset

    On Error GoTo ErrorHandler
    
    Dim rs As adodb.Recordset
    
    If Not (dbConn Is Nothing) Then
        'Open a recordset
        Set rs = New adodb.Recordset
        Call rs.Open(sql, dbConn, adOpenForwardOnly)
        Set SQLRecordset = rs
    Else
        MsgBox "Cannot open recordset when there is no active database connection"
    End If
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function

Public Function SQLToArray
    (
    ByRef dbConn As adodb.connection, 
    ByVal sql As String
    ) As Variant

    On Error GoTo ErrorHandler
    
    Dim rs As adodb.Recordset
    
    If Not (dbConn Is Nothing) Then
        'Open a recordset
        Set rs = New adodb.Recordset
        Call rs.Open(sql, dbConn, adOpenDynamic)
        SQLToArray = rs.GetRows()
    Else
        MsgBox "Cannot open recordset when there is no active database connection"
    End If
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function

Public Sub SQLToRangeName
    (
    ByRef dbConn As adodb.connection, 
    ByVal sql As String, 
    ByRef WSTarget As Worksheet, 
    ByVal rangeNameTarget As String, 
    ByVal headers As Boolean, 
    Optional ByVal cursorType As adodb.CursorTypeEnum = adodb.CursorTypeEnum.adOpenDynamic
    )
                                
    On Error GoTo ErrorHandler
    
    Dim rs As adodb.Recordset
    Dim rng As Range
    Dim rowCount As Long
    Dim fieldCount As Integer
    
    Set rng = WSTarget.Range(rangeNameTarget)
    
    If Not (dbConn Is Nothing) Then
        'Open a recordset
        Set rs = New adodb.Recordset
        Call rs.Open(sql, dbConn, cursorType)
        
        'Copy the headers if required
        If headers Then
            For fieldCount = 0 To rs.Fields.Count - 1
                rng.Cells(1, fieldCount + 1).Value = rs.Fields(fieldCount).Name
            Next fieldCount
        End If
        
        'Copy all the records
        rowCount = rng.Cells(IIf(headers, 2, 1), 1).CopyFromRecordset(rs)
        
        'Check the sizes for the range
        rowCount = rowCount + IIf(headers, 1, 0)
        If rowCount = 0 Then rowCount = 1
        If fieldCount = 0 Then fieldCount = 1
        
        'Resize the range
        Dim TheSheet As String
        Dim TopLeft As String
        Dim BottomRight As String
        Dim RefersToString As String
            
        TheSheet = rng.Worksheet.Name
        TopLeft = rng.Cells(1, 1).address
        BottomRight = rng.Cells(rowCount, fieldCount).address
        RefersToString = "='" & TheSheet & "'!" & TopLeft & ":" & BottomRight
        Application.Names(rangeNameTarget).refersTo = RefersToString
    Else
        MsgBox "Cannot open recordset when there is no active database connection"
    End If
    
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description
    
End Sub


Public Function SQLExecute
    (
    ByRef dbConn As adodb.connection, 
    ByVal sql As String
    ) As Long

    On Error GoTo ErrorHandler
    Dim recordsAffected As Long
    
    If Not (dbConn Is Nothing) Then
        'Run the SQL
        Call dbConn.Execute(sql, recordsAffected)
    Else
        MsgBox "Cannot open recordset when there is no active database connection"
    End If
    SQLExecute = recordsAffected
    
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    
End Function

# posted by Nick @ 12:42 PM