Public Sub SQLOpen(ByRef oCn As ADODB.Connection)
On Error GoTo ERR_GetConnectionString
Const REGISTRY_LOCATION As String = "SOFTWARE\MyCompany\DataAccess"
Const DEFAULT_CONNECTION_STRING As String = "Provider=%1;Password=%2;User ID=%3;Data Source=%4"
Dim oSPM As SharedPropertyGroupManager
Dim fAlreadyExists As Boolean
Dim oGroup As SharedPropertyGroup
Dim oSQLCnString As SharedProperty
Dim sProvider As String
Dim sServer As String
Dim sDatabase As String
Dim sUsername As String
Dim sPassword As String
Dim SQLConnectionString As String
'***************************************************************
'* Get the shared property (create it if it doesn't exist . . .
'***************************************************************
Set oSPM = New SharedPropertyGroupManager
Set oGroup = oSPM.CreatePropertyGroup("ConnectionStrings", LockMethod, Process, fAlreadyExists)
Set oSQLCnString = oGroup.CreateProperty("SQLConnectionString", fAlreadyExists)
'*****************************************************************************************
'* If we don't have this shared property, then get the information from the registry . . .
'*****************************************************************************************
If Not fAlreadyExists Then
Call Registry.GetValue(HKEY_LOCAL_MACHINE, REGISTRY_LOCATION, "SQLProvider", sProvider)
Call Registry.GetValue(HKEY_LOCAL_MACHINE, REGISTRY_LOCATION, "SQLDatabase", sDatabase)
Call Registry.GetValue(HKEY_LOCAL_MACHINE, REGISTRY_LOCATION, "SQLServer", sServer)
Call Registry.GetValue(HKEY_LOCAL_MACHINE, REGISTRY_LOCATION, "SQLUser", sUsername)
Call Registry.GetValue(HKEY_LOCAL_MACHINE, REGISTRY_LOCATION, "SQLPassword", sPassword)
'********************************************
'* Replace tokens with the correct data . . .
'********************************************
SQLConnectionString = DEFAULT_CONNECTION_STRING
SQLConnectionString = Replace(SQLConnectionString, "%1", sProvider)
SQLConnectionString = Replace(SQLConnectionString, "%2", sPassword)
SQLConnectionString = Replace(SQLConnectionString, "%3", sUsername)
SQLConnectionString = Replace(SQLConnectionString, "%4", sServer)
oSQLCnString.Value = SQLConnectionString
Else
SQLConnectionString = oSQLCnString.Value
End If
Set oSQLCnString = Nothing
Set oGroup = Nothing
Set oSPM = Nothing
'*******************************************************
'* Release existing connection, then recreate it . . .
'*******************************************************
SQLClose oCn
Set oCn = New ADODB.Connection
oCn.ConnectionString = SQLConnectionString
oCn.Open
Exit Sub
ERR_GetConnectionString:
SQLClose oCn
Set oSQLCnString = Nothing
Set oGroup = Nothing
Set oSPM = Nothing
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
Public Function SQLClose(oCn As ADODB.Connection)
If Not oCn Is Nothing Then
If oCn.State = adStateOpen Then
oCn.Close
End If
Set oCn = Nothing
End If
End Function