2
\$\begingroup\$

SecureADODB is a very instructive VBA OOP demo. I have played with SecureADODB for a while and plan to integrate it into the prototype of my database manager application. In my previous post, I showed ContactEditor's class diagram with the ADOlib class encapsulated into the DataTableADODB backend. The ADOlib class contains a few very basic wrappers around the ADODB library, and I created it as a stub to focus on other components of the db manager app. Now, I would like to replace ADOlib with SecureADODB. In preparation, I forked SecureADODB, slightly refactored the original codebase, and incorporated additional functionality from ADOlib. The focus of this question is on several modifications, particularly the DbManager class and two helper classes.


Class diagram of this SecureADODB fork (inteface classes not shown)

Class Diagram

DbManager (renamed UnitOfWork)

'@Folder "SecureADODB.DbManager"
'@ModuleDescription("An object that encapsulates a database transaction.")
'@PredeclaredId
'@Exposed
Option Explicit

Implements IDbManager

Private Type TDbManager
    DbMeta As DbMetaData
    DbConnStr As DbConnectionString
    Connection As IDbConnection
    CommandFactory As IDbCommandFactory
    UseTransactions As Boolean
    LogController As ILogger
End Type
Private this As TDbManager


'@Ignore ProcedureNotUsed
'@Description("Returns class reference")
Public Property Get Class() As DbManager
    Set Class = DbManager
End Property


'@Description("Default factory")
Public Function Create(ByVal db As IDbConnection, _
                       ByVal factory As IDbCommandFactory, _
              Optional ByVal UseTransactions As Boolean = True, _
              Optional ByVal LogController As ILogger = Nothing) As IDbManager
    Dim Instance As DbManager
    Set Instance = New DbManager
    Instance.Init db, factory, UseTransactions, LogController
    Set Create = Instance
End Function


'@Description("Default constructor")
Friend Sub Init(ByVal db As IDbConnection, _
                ByVal factory As IDbCommandFactory, _
       Optional ByVal UseTransactions As Boolean = True, _
       Optional ByVal LogController As ILogger = Nothing)
              
    Guard.NullReference factory
    Guard.NullReference db
    Guard.Expression db.State = adStateOpen, Source:="DbManager", Message:="Connection should be open."

    Set this.LogController = LogController
    Set this.Connection = db
    Set this.CommandFactory = factory
    this.UseTransactions = UseTransactions
End Sub


'''' Factory for file-based databases.
''''
'''' Args:
''''   DbType (string):
''''     Type of the database: "sqlite", "csv", "xls"
''''
''''   DbFileName (string, optional, ""):
''''     Database file name. If not provided, ThisWorkbook.VBProject.Name
''''     will be used. Extension is added based on the database type:
''''       "sqlite" - "db" or "sqlite"
''''       "csv"    - "xsv" or "csv"
''''       "xls"    - "xls
''''
''''   ConnectionOptions (variant, optional, Empty):
''''     Connection options. If Empty, default values is selected based on the
''''     database type (see DbConnectionString constructor code for details).
''''
''''  N.B.: "xls" backend support is not currently implemented
''''
'@Description "Factory for file-based databases"
Public Function CreateFileDb( _
                 ByVal DbType As String, _
        Optional ByVal DbFileName As String = vbNullString, _
        Optional ByVal ConnectionOptions As String = vbNullString, _
        Optional ByVal UseTransactions As Boolean = True, _
        Optional ByVal LoggerType As LoggerTypeEnum = LoggerTypeEnum.logGlobal _
        ) As IDbManager
    Dim LogController As ILogger
    Select Case LoggerType
        Case LoggerTypeEnum.logDisabled
            Set LogController = Nothing
        Case LoggerTypeEnum.logGlobal
            Set LogController = Logger
        Case LoggerTypeEnum.logPrivate
            Set LogController = Logger.Create
    End Select
    
    Dim provider As IParameterProvider
    Set provider = AdoParameterProvider.Create(AdoTypeMappings.Default)
    
    Dim baseCommand As IDbCommandBase
    Set baseCommand = DbCommandBase.Create(provider)
    
    Dim factory As IDbCommandFactory
    Set factory = DbCommandFactory.Create(baseCommand)
    
    Dim DbConnStr As DbConnectionString
    Set DbConnStr = DbConnectionString.CreateFileDb(DbType, DbFileName, , ConnectionOptions)
    Dim db As IDbConnection
    Set db = DbConnection.Create(DbConnStr.ConnectionString, LogController)
    
    Dim Instance As DbManager
    Set Instance = DbManager.Create(db, factory, UseTransactions, LogController)
    Set Instance.DbConnStr = DbConnStr
    Set Instance.DbMeta = DbMetaData.Create(DbConnStr)
    Set CreateFileDb = Instance
End Function


'@Ignore ProcedureNotUsed
Public Property Get DbConnStr() As DbConnectionString
    Set DbConnStr = this.DbConnStr
End Property


Public Property Set DbConnStr(ByVal Instance As DbConnectionString)
    Set this.DbConnStr = Instance
End Property


'@Ignore ProcedureNotUsed
Public Property Get DbMeta() As DbMetaData
    Set DbMeta = this.DbMeta
End Property


Public Property Set DbMeta(ByVal Instance As DbMetaData)
    Set this.DbMeta = Instance
End Property


'@Description("Returns class reference")
Public Property Get IDbManager_Class() As DbManager
    Set IDbManager_Class = DbManager
End Property


Private Property Get IDbManager_LogController() As ILogger
    Set IDbManager_LogController = this.LogController
End Property


Private Property Get IDbManager_DbConnStr() As DbConnectionString
    Set IDbManager_DbConnStr = this.DbConnStr
End Property


Private Property Get IDbManager_DbMeta() As DbMetaData
    Set IDbManager_DbMeta = this.DbMeta
End Property


Private Property Get IDbManager_Connection() As IDbConnection
    Set IDbManager_Connection = this.Connection
End Property


Private Function IDbManager_Command() As IDbCommand
    Set IDbManager_Command = this.CommandFactory.CreateInstance(this.Connection)
End Function


Private Function IDbManager_Recordset( _
        Optional ByVal Scalar As Boolean = False, _
        Optional ByVal Disconnected As Boolean = True, _
        Optional ByVal CacheSize As Long = 10, _
        Optional ByVal CursorType As ADODB.CursorTypeEnum = -1, _
        Optional ByVal AsyncMode As Boolean = False, _
        Optional ByVal AsyncOption As ADODB.ExecuteOptionEnum = 0) As IDbRecordset
    Dim cmd As IDbCommand
    Set cmd = this.CommandFactory.CreateInstance(this.Connection)
    Set IDbManager_Recordset = DbRecordset.Create( _
        cmd, Scalar, Disconnected, CacheSize, CursorType, AsyncMode, AsyncOption)
End Function


Private Sub IDbManager_Begin()
    Guard.Expression this.UseTransactions, Source:="DbManager", Message:="Transactions are disabled by the caller."
    this.Connection.BeginTransaction
End Sub


Private Sub IDbManager_Commit()
    Guard.Expression this.UseTransactions, Source:="DbManager", Message:="Transactions are disabled by the caller."
    this.Connection.CommitTransaction
End Sub


Private Sub IDbManager_Rollback()
    Guard.Expression this.UseTransactions, Source:="DbManager", Message:="Transactions are disabled by the caller."
    this.Connection.RollbackTransaction
End Sub

While this DbManager class is functionally similar to the UnitOfWork class in RD SecureADODB, I added two helper classes to simplify specific tasks.

DbConnectionString

During the prototyping stage, I do not want to worry about config files and connection string issues. So using this class for file-based databases (currently SQLite and CSV backends are supported), I can simply indicate the type of the database and get a connection string with sane defaults.

'@Folder "SecureADODB.DbManager.DbConnectionString"
'@ModuleDescription "Helper routines for building connection strings"
'@PredeclaredId
'@Exposed
''''
'''' The module incorporates routines, which facilitate construction of
'''' connection strings for the ADODB library. Presently, a distinction is made
'''' between file-based databases, such as sqlite, csv, xls, etc., and network
'''' based databases. A file-based database is accessed based on its type and
'''' file pathname.
'''' CreateFileDB/InitFileDB pair is used for file based databases.
''''
Option Explicit
Option Compare Text

Private Type TDbConnectionString
    DbType As String
    DbPath As String
    Options As String
    Driver As String
    ConnectionString As String
End Type
Private this As TDbConnectionString


'''' Factory for file-based databases.
''''
'''' Args:
''''   FileType (string, optional, "sqlite"):
''''     Type of the database: "sqlite", "csv", "xls"
''''
''''   FileName (string, optional, ""):
''''     Database file name. If not provided, ThisWorkbook.VBProject.Name
''''     will be used. Extension is added based on the database type:
''''       "sqlite" - "db" or "sqlite"
''''       "csv"    - "xsv" or "csv"
''''       "xls"    - "xls
''''
''''   Driver (variant, optional, Empty):
''''     Database driver. If Empty, default values is selected based on
''''     the database type (see constructor code for details).
''''
''''   ConnectionOptions (variant, optional, Empty):
''''     Connection options. See above for details.
''''
''''  N.B.: "xls" backend support is not currently implemented
''''
'''' Examples:
''''   >>> ?DbConnectionString.CreateFileDB("sqlite").ConnectionString
''''   "Driver=SQLite3 ODBC Driver;Database=<Thisworkbook.Path>\SecureADODB.db;SyncPragma=NORMAL;FKSupport=True;"
''''
''''   >>> ?DbConnectionString.CreateFileDB("sqlite").QTConnectionString
''''   "OLEDB;Driver=SQLite3 ODBC Driver;Database=<Thisworkbook.Path>\SecureADODB.db;SyncPragma=NORMAL;FKSupport=True;"
''''
''''   >>> ?DbConnectionString.CreateFileDB("csv").ConnectionString
''''   "Driver={Microsoft Text Driver (*.txt; *.csv)};DefaultDir=<Thisworkbook.Path>;"
''''
''''   >>> ?DbConnectionString.CreateFileDB("xls").ConnectionString
''''   NotImplementedErr
''''
'@Description "Factory for file-based databases"
Public Function CreateFileDb(Optional ByVal FileType As String = "sqlite", _
                             Optional ByVal FileName As String = vbNullString, _
                             Optional ByVal Driver As Variant = Empty, _
                             Optional ByVal ConnectionOptions As Variant = Empty _
                            ) As DbConnectionString
    Dim Instance As DbConnectionString
    Set Instance = New DbConnectionString
    Instance.InitFileDB FileType, FileName, Driver, ConnectionOptions
    Set CreateFileDb = Instance
End Function


'@Description "Constructor for file-based databases"
Friend Sub InitFileDB(Optional ByVal FileType As String = "sqlite", _
                      Optional ByVal FileName As String = vbNullString, _
                      Optional ByVal Driver As String = vbNullString, _
                      Optional ByVal ConnectionOptions As Variant = Empty)
    With this
        .DbType = LCase$(FileType)
        .Driver = Driver
        .Options = ConnectionOptions
        Select Case .DbType
            Case "sqlite"
                If Len(Driver) = 0 Then
                    .Driver = "SQLite3 ODBC Driver"
                End If
                If IsEmpty(ConnectionOptions) Then
                    .Options = "SyncPragma=NORMAL;FKSupport=True;"
                End If
                .DbPath = VerifyOrGetDefaultPath(FileName, Array("db", "sqlite"))
                .ConnectionString = "Driver=" + .Driver + ";" + _
                                    "Database=" + .DbPath + ";" + _
                                    .Options
            Case "worksheet", "wsheet"
                .DbPath = VerifyOrGetDefaultPath(FileName, Array("xls"))
                .ConnectionString = .DbPath
            Case "csv"
                .DbPath = VerifyOrGetDefaultPath(FileName, Array("xsv", "csv"))
                Dim DbFileName As String
                DbFileName = Dir$(.DbPath, vbArchive + vbNormal + vbHidden + vbReadOnly + vbSystem)
                .DbPath = Left$(.DbPath, Len(.DbPath) - Len(DbFileName) - 1)
                #If Win64 Then
                    .Driver = "Microsoft Access Text Driver (*.txt, *.csv)"
                #Else
                    .Driver = "{Microsoft Text Driver (*.txt; *.csv)}"
                #End If
                .ConnectionString = "Driver=" + .Driver + ";" + _
                                    "DefaultDir=" + .DbPath + ";"
            Case Else
                .ConnectionString = vbNullString
        End Select
    End With

    If this.ConnectionString = vbNullString Then
        Dim errorDetails As TError
        With errorDetails
            .Number = ErrNo.NotImplementedErr
            .Name = "NotImplementedErr"
            .Source = "DbConnectionString"
            .Description = "Unsupported backend: " & FileType
            .Message = .Description
        End With
        RaiseError errorDetails
    End If
End Sub


Public Property Get ConnectionString() As String
    ConnectionString = this.ConnectionString
End Property


Public Property Get QTConnectionString() As String
    QTConnectionString = "OLEDB;" & this.ConnectionString
End Property

DbConnectionString relies on the VerifyOrGetDefaultPath routine, which takes a file pathname candidate (possibly blank) and an array of default extensions. Then it attempts to locate the file, checking default directories and file naming conventions.

'''' Resolves file pathname
''''
'''' This helper routines attempts to interpret provided pathname as
'''' a reference to an existing file:
'''' 1) check if provided reference is a valid absolute file pathname, if not,
'''' 2) construct an array of possible file locations:
''''      - ThisWorkbook.Path & Application.PathSeparator
''''      - Environ("APPDATA") & Application.PathSeparator &
''''          & ThisWorkbook.VBProject.Name & Application.PathSeparator
''''    construct an array of possible file names:
''''      - FilePathName
''''      - ThisWorkbook.VBProject.Name & Ext (Ext comes from the second argument
'''' 3) loop through all possible path/filename combinations until a valid
''''    pathname is found or all options are exhausted
''''
'''' Args:
''''   FilePathName (string):
''''     File pathname
''''
''''   DefaultExts (string or string/array):
''''     1D array of default extensions or a single default extension
''''
'''' Returns:
''''   String:
''''     Resolved valid absolute pathname pointing to an existing file.
''''
'''' Throws:
''''   Err.FileNotFoundErr:
''''     If provided pathname cannot be resolved to a valid file pathname.
''''
'''' Examples:
''''   >>> ?VerifyOrGetDefaultPath(Environ$("ComSpec"), "")
''''   "C:\Windows\system32\cmd.exe"
''''
'@Description "Resolves file pathname"
Public Function VerifyOrGetDefaultPath(ByVal FilePathName As String, ByVal DefaultExts As Variant) As String
    Dim PATHuSEP As String: PATHuSEP = Application.PathSeparator
    Dim PROJuNAME As String: PROJuNAME = ThisWorkbook.VBProject.Name
    
    Dim FileExist As Variant
    Dim PathNameCandidate As String
        
    '''' === (1) === Check if FilePathName is a valid path to an existing file.
    If Len(FilePathName) > 0 Then
        '''' If matched, Dir returns Len(String) > 0;
        '''' otherwise, returns vbNullString or raises an error
        PathNameCandidate = FilePathName
        On Error Resume Next
        FileExist = FileLen(PathNameCandidate)
        On Error GoTo 0
        If FileExist > 0 Then
            VerifyOrGetDefaultPath = PathNameCandidate
            Exit Function
        End If
    End If
    
    '''' === (2a) === Array of prefixes
    Dim Prefixes As Variant
    Prefixes = Array( _
        ThisWorkbook.Path & PATHuSEP, _
        Environ$("APPDATA") & PATHuSEP & PROJuNAME & PATHuSEP _
    )
    
    '''' === (2b) === Array of filenames
    Dim NameCount As Long
    NameCount = 0
    If Len(FilePathName) > 1 And InStr(FilePathName, PATHuSEP) = 0 Then
        NameCount = NameCount + 1
    End If
    If VarType(DefaultExts) = vbString Then
        If Len(DefaultExts) > 0 Then NameCount = NameCount + 1
    ElseIf VarType(DefaultExts) >= vbArray Then
        NameCount = NameCount + UBound(DefaultExts, 1) - LBound(DefaultExts, 1) + 1
        Debug.Assert VarType(DefaultExts(0)) = vbString
    End If
    If NameCount = 0 Then
        VBA.Err.Raise _
            Number:=ErrNo.FileNotFoundErr, _
            Source:="CommonRoutines", _
            Description:="File <" & FilePathName & "> not found!"
    End If
    
    Dim FileNames() As String
    ReDim FileNames(0 To NameCount - 1)
    Dim ExtIndex As Long
    Dim FileNameIndex As Long
    FileNameIndex = 0
    If Len(FilePathName) > 1 And InStr(FilePathName, PATHuSEP) = 0 Then
        FileNames(FileNameIndex) = FilePathName
        FileNameIndex = FileNameIndex + 1
    End If
    If VarType(DefaultExts) = vbString Then
        If Len(DefaultExts) > 0 Then
            FileNames(FileNameIndex) = PROJuNAME & "." & DefaultExts
        End If
    ElseIf VarType(DefaultExts) >= vbArray Then
        For ExtIndex = LBound(DefaultExts, 1) To UBound(DefaultExts, 1)
            FileNames(FileNameIndex) = PROJuNAME & "." & DefaultExts(ExtIndex)
            FileNameIndex = FileNameIndex + 1
        Next ExtIndex
    End If
    
    '''' === (3) === Loop through pathnames
    Dim PrefixIndex As Long
    
    On Error Resume Next
    For PrefixIndex = 0 To UBound(Prefixes)
        For FileNameIndex = 0 To UBound(FileNames)
            PathNameCandidate = Prefixes(PrefixIndex) & FileNames(FileNameIndex)
            FileExist = FileLen(PathNameCandidate)
            Err.Clear
            If FileExist > 0 Then
                VerifyOrGetDefaultPath = Replace$(PathNameCandidate, _
                                                  PATHuSEP & PATHuSEP, PATHuSEP)
                Exit Function
            End If
        Next FileNameIndex
    Next PrefixIndex
    On Error GoTo 0
    
    VBA.Err.Raise _
        Number:=ErrNo.FileNotFoundErr, _
        Source:="CommonRoutines", _
        Description:="File <" & FilePathName & "> not found!"
End Function

DbMetaData

DbMetaData currently provides a routine, which takes a table name and returns field names, types, and a mapping from field name to its position.

'@Folder "SecureADODB.DbManager.DbMetaData"
'@ModuleDescription "Database introspection functionality"
'@PredeclaredId
'@Exposed
Option Explicit

Private Type TDbMeta
    DbConnStr As DbConnectionString
End Type
'@Ignore MoveFieldCloserToUsage: Follow the standard pattern
Private this As TDbMeta


'@Description "Default factory"
Public Function Create(ByVal DbConnStr As DbConnectionString) As DbMetaData
    Dim Instance As DbMetaData
    Set Instance = New DbMetaData
    Instance.Init DbConnStr
    Set Create = Instance
End Function


'@Description "Default constructor"
Friend Sub Init(ByVal DbConnStr As DbConnectionString)
    Guard.NullReference DbConnStr
    Set this.DbConnStr = DbConnStr
End Sub


'@Ignore ParameterCanBeByVal: False positive
'@Description "Query table field metadata via the ADOX library"
Public Sub QueryTableADOXMeta(ByVal TableName As String, _
                              ByRef FieldNames As Variant, _
                              ByRef FieldTypes As Variant, _
                              ByVal FieldMap As Scripting.Dictionary)
    Dim Catalog As ADOX.Catalog
    Set Catalog = New ADOX.Catalog
    Catalog.ActiveConnection = this.DbConnStr.ConnectionString
    Dim Table As ADOX.Table
    '@Ignore IndexedDefaultMemberAccess
    Set Table = Catalog.Tables(TableName)
    Dim FieldCount As Long
    FieldCount = Table.Columns.Count
    
    ReDim FieldNames(1 To FieldCount)
    ReDim FieldTypes(1 To FieldCount)
    
    Dim Column As ADOX.Column
    Dim FieldIndex As Long
    For FieldIndex = 1 To FieldCount
        '@Ignore IndexedDefaultMemberAccess
        Set Column = Table.Columns(FieldIndex - 1)
        FieldNames(FieldIndex) = Column.Name
        FieldTypes(FieldIndex) = Column.Type
        '@Ignore IndexedDefaultMemberAccess
        FieldMap(Column.Name) = FieldIndex
    Next FieldIndex
End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.