VBA/Db.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Db"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'==========================================================================
' Db - a single database connection (modern successor to the ADOp_* helpers
'      in TheBigOne). Late-bound ADO, so no project reference is required;
'      import the class and go.
'
' Defaults to the SQLOLEDB OLE DB provider (built into Windows - zero install,
' works for non-admin users), but Provider is settable.
'
'   Dim db As New Db
'   If db.OpenSqlServer("USMIDSQL01", "fanalysis") Then
'       If db.Exec(batchSql) Then ... Else MsgBox db.LastError
'       Dim a As Variant: a = db.Query("SELECT ...")   ' 2D, row 1 = headers
'       db.CloseConn
'   End If
'==========================================================================

Option Explicit

Private mConn As Object         ' ADODB.Connection (late bound)
Private mErr As String
Private mProvider As String
Private mTimeout As Long
Private mRows As Long


Private Sub Class_Initialize()
    mProvider = "SQLOLEDB"
    mTimeout = 600
End Sub

Private Sub Class_Terminate()
    CloseConn
    Set mConn = Nothing
End Sub


'----- properties ---------------------------------------------------------

Public Property Get Provider() As String
    Provider = mProvider
End Property
Public Property Let Provider(ByVal value As String)
    mProvider = value
End Property

Public Property Get CommandTimeout() As Long
    CommandTimeout = mTimeout
End Property
Public Property Let CommandTimeout(ByVal value As Long)
    mTimeout = value
End Property

Public Property Get LastError() As String
    LastError = mErr
End Property

Public Property Get RowsAffected() As Long
    RowsAffected = mRows
End Property

Public Property Get IsOpen() As Boolean
    IsOpen = (Not mConn Is Nothing)
    If IsOpen Then IsOpen = (mConn.State <> 0)
End Property


'----- open / close -------------------------------------------------------

' Open a SQL Server connection. Integrated (Windows) security by default.
Public Function OpenSqlServer(ByVal server As String, _
                              Optional ByVal database As String = "", _
                              Optional ByVal integratedSecurity As Boolean = True, _
                              Optional ByVal user As String = "", _
                              Optional ByVal password As String = "") As Boolean
    Dim cs As String
    cs = "Provider=" & mProvider & ";Data Source=" & server & ";"
    If Len(database) > 0 Then cs = cs & "Initial Catalog=" & database & ";"
    If integratedSecurity Then
        cs = cs & "Integrated Security=SSPI;"
    Else
        cs = cs & "User ID=" & user & ";Password=" & password & ";"
    End If
    OpenSqlServer = OpenConnString(cs)
End Function

' Open with any provided connection string.
Public Function OpenConnString(ByVal connString As String) As Boolean
    On Error GoTo fail
    mErr = ""
    If mConn Is Nothing Then Set mConn = CreateObject("ADODB.Connection")
    If mConn.State <> 0 Then mConn.Close
    mConn.Open connString
    OpenConnString = True
    Exit Function
fail:
    mErr = "Open failed: " & Err.Number & " - " & Err.Description
    OpenConnString = False
End Function

Public Sub CloseConn()
    On Error Resume Next
    If Not mConn Is Nothing Then
        If mConn.State <> 0 Then mConn.Close
    End If
End Sub


'----- execute / query ----------------------------------------------------

' Run a statement or multi-statement batch. RowsAffected is set after.
Public Function Exec(ByVal sql As String) As Boolean
    On Error GoTo fail
    mErr = "": mRows = 0
    If Not IsOpen Then
        mErr = "Connection is not open."
        Exec = False
        Exit Function
    End If
    mConn.CommandTimeout = mTimeout
    Dim affected As Variant
    mConn.Execute sql, affected
    If Not IsEmpty(affected) Then mRows = CLng(affected)
    Exec = True
    Exit Function
fail:
    mErr = "Exec failed: " & Err.Number & " - " & Err.Description
    Exec = False
End Function

' Run a query and return a 2D Variant array (1-based). Row 1 = headers when
' includeHeaders. Returns Empty on error or no columns; check LastError.
Public Function Query(ByVal sql As String, Optional ByVal includeHeaders As Boolean = True) As Variant
    On Error GoTo fail
    mErr = ""
    If Not IsOpen Then
        mErr = "Connection is not open."
        Query = Empty
        Exit Function
    End If
    mConn.CommandTimeout = mTimeout

    Dim rs As Object
    Set rs = mConn.Execute(sql)
    Query = RecordsetToArray(rs, includeHeaders)
    On Error Resume Next
    rs.Close
    Exit Function
fail:
    mErr = "Query failed: " & Err.Number & " - " & Err.Description
    Query = Empty
End Function


'----- helpers ------------------------------------------------------------

Private Function RecordsetToArray(ByVal rs As Object, ByVal includeHeaders As Boolean) As Variant
    Dim nCols As Long, i As Long, j As Long
    nCols = rs.Fields.Count
    If nCols = 0 Then
        RecordsetToArray = Empty
        Exit Function
    End If

    Dim block As Variant, nData As Long
    If Not (rs.BOF And rs.EOF) Then
        block = rs.GetRows                         ' 0-based (col, row)
        nData = UBound(block, 2) - LBound(block, 2) + 1
    End If

    Dim hdrOff As Long
    hdrOff = IIf(includeHeaders, 1, 0)

    If nData + hdrOff = 0 Then
        RecordsetToArray = Empty
        Exit Function
    End If

    Dim out() As Variant
    ReDim out(1 To nData + hdrOff, 1 To nCols)
    If includeHeaders Then
        For j = 0 To nCols - 1
            out(1, j + 1) = rs.Fields(j).Name
        Next j
    End If
    For i = 0 To nData - 1
        For j = 0 To nCols - 1
            out(i + 1 + hdrOff, j + 1) = block(j, i)
        Next j
    Next i

    RecordsetToArray = out
End Function