Thursday, August 11, 2005

 

Rule 18: Centralise DB code

Here is some centralised DB access code



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


Comments: Post a Comment





<< Home

This page is powered by Blogger. Isn't yours?

Subscribe to Posts [Atom]