Connection Server Function
Post date: Dec 18, 2013 5:05:45 PM
To speed up SQL processing in VBA, we need to reuse connections because opening connections is slow. To facilitate reusing connections in any SQL routine, I created a "Connection Server" function. Its job is to provide connections to other functions. If the connection exists, it just hands it to the calling routine. If the connection doesn't exist, it creates it, opens it, saves it, and serves it to the calling routine. And when needed, it can also close our connections. Below is the Connection table used by the Connection Server. The Connection Server's code is at bottom. And for more on BXL's Connection Server see this PDF (click link).
The connection table (tblConnections) fields are:
ID
Type
Connection String
DBQ
DB
Unique ID for connections. Name this anything you like as long as each ID is unique within this table
* When DB = "?", Type becomes FileOpen()'s filter.
* When DB = "*Type" Type replaces the current workbook's extension
* When DB is anything else Type is just a comment.
DBMS properties required to establish a connection between XL and the DB. Use <DBQ> and <DB> to designate where these values go in the connection string.
Example (Access): Provider=Microsoft.ACE.OLEDB.12.0;Data Source=<DBQ>\<DB>;
References:
* What is a connection string? en.wikipedia.org/wiki/Connection_string
* Where can I find the connection string for my DBMS? connectionstrings.com
Database location which can be:
* A path to file based DBMSs. "*Path" indicates DB is in Workbook's Path
* An IP address or Server Name for server based DBMSs
Database to use from DBMS which can be:
* A filename for file based DBMSs
* Varies by vendor for server based DBMSs.
These special entries can be used:
?
*Type
*FileName
Find DB using FileOpen() dialog
Workbook's filename w/Type's extension
Current workbook
NOTE!
See Error Handling for my error handling routines used here.
See Data Dictionary if you are new to the dictionary object.
See ConnectionStrings for help on connecting to databases
Private Const cModule As String = "modExpImp" 'Module where I store this
Global Const NoError As Long = 0 'No Error
Global Const LogError As Long = 997 'Log Error
Global Const RtnError As Long = 998 'Return Error
Global Const DspError As Long = 999 'Display Error
Public Function Get_Connection(ByVal sID As String, _
Optional ByVal bClose As Boolean = False) As Object
' Description:Get an existing connection -or-
' Create a connection and return a connection -or-
' Close a single or all connections
' Inputs: sID Name of connection to get, create or close
' "*" will close all connections
' bClose Close connection(s)
' Outputs: Me Success: Connection Object
' Failure: Nothing
' Requisites: Tables: tblConnections
' Routines: FileOpen()
' Examples: Get or create a single opened connection
' Set cn = Get_Connection("NorthWind")
' Close all connections
' Get_Connection "*", TRUE
' Date Ini Modification
' 08/14/11 CWH Original programming
' 01/15/13 CWH Version 2013.01
' 06/10/13 CWH Server identification changes
' 12/18/13 CWH Ready for publication
' Declarations
Dim sRoutine As String 'Routine's Name
Dim sType As String 'Database Type Specified in Connections Table
Dim sDBQ As String 'Database Location Specified in Connections Table
Dim sDB As String 'Database Specified in Connections Table
Dim sCN As String 'Current Connection String
Dim oCN As Object 'Current Connection Object
Dim v As Variant 'Generic Variant
Dim s As String 'Generic String
Static dicCNo As Object 'Connection Object Container
Static dicCNs As Object 'Connection String Container
' Error Handling Initialization
On Error GoTo ErrHandler
sRoutine = cModule & ".Get_Connection"
Set Get_Connection = Nothing
' Check Inputs and Requisites
If dicCNo Is Nothing Then
Set dicCNo = CreateObject("Scripting.Dictionary")
dicCNo.CompareMode = vbTextCompare 'Case Insensitive
End If
If dicCNs Is Nothing Then
Set dicCNs = CreateObject("Scripting.Dictionary")
dicCNs.CompareMode = vbTextCompare 'Case Insensitive
End If
' Procedure
' Get Connection if Exists in container/dictionary
If dicCNo.Exists(sID) Then
Set oCN = dicCNo(sID)
sCN = dicCNs(sID)
End If
' Create Connection String if needed
If sCN = "" Then
With ActiveSheet
s = "=INDEX(tblConnections[<Column>]," & _
"MATCH(""" & sID & """,tblConnections[ID],0))"
sCn = .Evaluate(Replace(s, "<Column>", "Connection String"))
sDBQ = .Evaluate(Replace(s, "<Column>", "DBQ"))
sDB = .Evaluate(Replace(s, "<Column>", "DB"))
sType = .Evaluate(Replace(s, "<Column>", "Type"))
If sDBQ = vbNullString Or sDB = vbNullString Then
v = FileOpen(sDefault:=sDBQ & sDB, _
sFilterText:=sID, _
sFilter:=sType, _
sTitle:="Select Database")
If v = vbNullString Then Err.Raise LogError, , "User Cancelled"
sDBQ = Left(v, InStrRev(v, "\") - 1)
sDB = Right(v, Len(v) - InStrRev(v, "\"))
End If
End With
sCn = Replace(sCn, "<DBQ>", sDBQ)
sCn = Replace(sCn, "<DB>", sDB)
End If
' Create Connection Object if needed
If oCN Is Nothing And sID <> "*" Then
Set oCN = CreateObject("ADODB.Connection")
Set dicCno(sID) = oCN
dicCns(sID) = sCn
End If
' Close Connection(s)
If bClose Or sID = "*" Then
If sID = "*" Then
For Each v In dicCno.Items
If v.State = 1 Then v.Close
Next
Else
If oCN.State = 1 Then oCN.Close
End If
' Open Connection
Else
Set oCN = dicCno(sID)
If oCN.State = 0 Then oCN.Open dicCns(sID)
End If
' Return Connection
Set Get_Connection = oCN
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(sRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Private Function FileOpen(Optional sDefault As String, _
Optional sFilterText As String, _
Optional sFilter As String, _
Optional sTitle As String = "Open File") As String
' Description:Display FileOpen Dialog
' Inputs: sDefault Default file name or initial path
' sFilterText Filter description (ex. "Databases")
' sFilter Extension filter (ex. "*mdb; *.accdb")
' sTitle Dialog Title (ex. "Select Database")
' Outputs: Me Success: File name w/path
' Failure: ""
' Requisites: *None
' Notes: msoFileDialogOpen = 1
' Adapted from Kenneth Hobson's post Aug 24th, 2011 in MrExcel's forum:
' www.mrexcel.com/forum/excel-questions/574110-getopenfilename-default-directory.html
' See also http://msdn.microsoft.com/en-us/library/office/aa432348(v=office.12).aspx
' Example: ?FileOpen
' ?FileOpen(sDefault:=ThisWorkbook.Path & "\")
' ?FileOpen(ThisWorkbook.Path & "\", "MS Access", _
' "*.mdb; *.accdb", "Select Database")
' ?FileOpen(oCn.DefaultDatabase, sTitle:="Select Database")
' Date Ini Modification
' 01/19/13 CWH Initial Programming (see Notes)
' 08/20/13 CWH Added documentation and Default changes
' Declarations
Dim sRoutine As String 'Routine's Name
' Error Handling Initialization
On Error GoTo ErrHandler
sRoutine = cModule & ".FileOpen"
' Procedure
With Application.FileDialog(1)
.ButtonName = "&Open"
If (.InitialFileName = "" Or _
.InitialFileName = "Network\") And _
sDefault = "" Then sDefault = ThisWorkbook.Path
.InitialFileName = sDefault
.Filters.Clear
If sFilter <> "" Then .Filters.Add sFilterText, sFilter, 1
.Title = sTitle
.AllowMultiSelect = False
If .Show Then FileOpen = .SelectedItems(1)
End With
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(sRoutine)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Select
End Function
Download
User guide at: https://www.dropbox.com/s/u28weawslupvl5c/ConnectionServer.pdf?dl=0
Keep posted on BXL offerings by subscribing to BXL's Facebook page or discuss this post or other BXL topics at: facebook.com/BeyondExcel