3
\$\begingroup\$

I am playing with a custom-built SQLite library intending to access it from VBA via the C-language API. I keep the library within the project folder, so I load it via the LoadLibrary API. To make the load/unload process more robust, I created the DllManager class wrapping the LoadLibrary, FreeLibrary, and SetDllDirectory APIs. DllManager can be used for loading/unloading multiple DLLs. It wraps a Scripting.Dictionary object to hold <DLL name> → <DLL handle> mapping.

DllManager.Create factory takes one optional parameter, indicating the user's DLL location, and passes it to DllManager.Init constructor. Ultimately, the DefaultPath setter (Property Let) handles this parameter. The setter checks if the parameter holds a valid absolute or a relative (w.r.t. ThisWorkbook.Path) path. If this check succeeds, SetDllDirectory API sets the default DLL search path. DllManager.ResetDllSearchPath can be used to reset the DLL search path to its default value.

DllManager.Load loads individual libraries. It takes the target library name and, optionally, path. If the target library has not been loaded, it attempts to resolve the DLL location by checking the provided value and the DefaultPath attribute. If resolution succeeds, the LoadLibrary API is called. DllManager.Free, in turn, unloads the previously loaded library.

DllManager.LoadMultiple loads a list of libraries. It takes a variable list of arguments (ParamArray) and loads them in the order provided. Alternatively, it also accepts a 0-based array of names as the sole argument. This routine has a dependency UnfoldParamArray (see CommonRoutines module and the Guard subpackage), handling the "array argument" case; otherwise, this dependency can be removed. DllManager.FreeMultiple is the counterpart of .LoadMultiple with the same interface. If no arguments are provided, all loaded libraries are unloaded.

Finally, while .Free/.FreeMultiple can be called explicitly, Class_Terminate calls .FreeMultiple and .ResetDllSearchPath automatically before the object is destroyed.

DllManager.cls

#If VBA7 Then
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryW" (ByVal lpPathName As String) As Boolean
#Else
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function SetDllDirectory Lib "kernel32" Alias "SetDllDirectoryW" (ByVal lpPathName As String) As Boolean
#End If

Private Const LOAD_OK As Long = -1
Private Const LOAD_FAIL As Long = 0
Private Const LOAD_ALREADY_LOADED As Long = 1

Private Type TDllManager
    DefaultPath As String
    Dlls As Scripting.Dictionary
End Type
Private this As TDllManager


'@DefaultMember
Public Function Create(Optional ByVal DefaultPath As String = vbNullString) As DllManager
    Dim Instance As DllManager
    Set Instance = New DllManager
    Instance.Init DefaultPath
    Set Create = Instance
End Function


Friend Sub Init(Optional ByVal DefaultPath As String = vbNullString)
    Set this.Dlls = New Scripting.Dictionary
    this.Dlls.CompareMode = TextCompare
    Me.DefaultPath = DefaultPath
End Sub


Private Sub Class_Terminate()
    ResetDllSearchPath
    FreeMultiple
End Sub


Public Property Get Dlls() As Scripting.Dictionary
    Set Dlls = this.Dlls
End Property


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


Public Property Let DefaultPath(ByVal Value As String)
    '@Ignore SelfAssignedDeclaration: Stateless utility object
    Dim fso As New Scripting.FileSystemObject
    Dim Path As String
    If fso.FolderExists(Value) Then
        '''' Absolute existing path is provided
        Path = Value
    ElseIf fso.FolderExists(fso.BuildPath(ThisWorkbook.Path, Value)) Then
        '''' Relative existing path is provided
        Path = fso.BuildPath(ThisWorkbook.Path, Value)
    Else
        Err.Raise ErrNo.FileNotFoundErr, "DllManager", _
                  "DefaultPath not found: <" & Value & ">"
    End If
    Path = fso.GetAbsolutePathName(Path)
    
    '''' Set the default dll directory for LoadLibrary
    '''' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-setdlldirectorya#remarks
    Dim ExecStatus As Boolean
    ExecStatus = SetDllDirectory(Path)
    If ExecStatus Then
        this.DefaultPath = Path
    Else
        Debug.Print "SetDllDirectory failed. Error code: " & CStr(Err.LastDllError)
    End If
End Property


'''' https://docs.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-setdlldirectorya#remarks
Public Sub ResetDllSearchPath()
    Dim ExecStatus As Boolean
    ExecStatus = SetDllDirectory(vbNullString)
    If ExecStatus Then
        this.DefaultPath = vbNullString
    Else
        Debug.Print "Reset SetDllDirectory failed. Error code: " & CStr(Err.LastDllError)
    End If
End Sub


Public Function Load(ByVal DllName As String, Optional ByVal Path As String = vbNullString) As Long
    '@Ignore SelfAssignedDeclaration: Stateless utility object
    Dim fso As New Scripting.FileSystemObject
    Dim FileName As String
    FileName = fso.GetFileName(DllName)
    
    If this.Dlls.Exists(FileName) Then
        Debug.Print "A library with file name <" & FileName & "> has already been loaded."
        Load = LOAD_ALREADY_LOADED
        Exit Function
    End If
    
    Dim Prefix As String
    If fso.FolderExists(Path) Then
        '''' Absolute existing path is provided
        Prefix = Path
    ElseIf fso.FolderExists(fso.BuildPath(ThisWorkbook.Path, Path)) Then
        '''' Relative existing path is provided
        Prefix = fso.BuildPath(ThisWorkbook.Path, Path)
    Else
        '''' Default path
        Prefix = fso.BuildPath(fso.BuildPath(ThisWorkbook.Path, "Library"), _
                               ThisWorkbook.VBProject.Name)
    End If
    Prefix = fso.GetAbsolutePathName(Prefix)
    
    
    Dim FilePathName As String
    If fso.FileExists(DllName) Then
        FilePathName = DllName
    ElseIf fso.FileExists(fso.BuildPath(Prefix, DllName)) Then
        FilePathName = fso.BuildPath(Prefix, DllName)
    ElseIf fso.FileExists(fso.BuildPath(this.DefaultPath, DllName)) Then
        FilePathName = fso.BuildPath(this.DefaultPath, DllName)
    Else
        Err.Raise ErrNo.FileNotFoundErr, "DllManager", _
                  "DllName not found: <" & DllName & ">"
    End If
    FilePathName = fso.GetAbsolutePathName(FilePathName)
    
    Dim DllHandle As Long
    DllHandle = LoadLibrary(FilePathName)
    If DllHandle <> 0 Then
        '@Ignore IndexedDefaultMemberAccess: Dictionary
        this.Dlls(FileName) = DllHandle
        Debug.Print "<" & DllName & "> loaded."
        Load = LOAD_OK
    Else
        Debug.Print "Library <" & FilePathName & "> loading error: " & CStr(Err.LastDllError)
        Load = LOAD_FAIL
    End If
End Function


Public Function Free(Optional ByVal DllName As String) As Long
    '@Ignore SelfAssignedDeclaration: Stateless utility object
    Dim fso As New Scripting.FileSystemObject
    Dim FileName As String
    FileName = fso.GetFileName(DllName)
    Dim Result As Long
    If Not this.Dlls.Exists(FileName) Then
        Debug.Print "<" & DllName & "> not loaded."
        Free = LOAD_OK
    Else
        Result = FreeLibrary(this.Dlls(FileName))
        If Result <> 0 Then
            Debug.Print "<" & DllName & "> unloaded."
            Free = LOAD_OK
            this.Dlls.Remove FileName
        Else
            Free = LOAD_FAIL
            Debug.Print "Error unloading <" & DllName & ">. Result: " _
                & CStr(Result) & ". LastDllError: "; CStr(Err.LastDllError)
        End If
    End If
End Function


Public Function LoadMultiple(ParamArray DllNames() As Variant) As Long
    Dim Result As Long
    Result = LOAD_OK
    Dim FileNames() As Variant
    FileNames = UnfoldParamArray(DllNames)
    Dim FileNameIndex As Long
    For FileNameIndex = LBound(FileNames) To UBound(FileNames)
        Result = Result And Load(FileNames(FileNameIndex))
    Next FileNameIndex
    LoadMultiple = -Abs(Result)
End Function


Public Function FreeMultiple(ParamArray DllNames() As Variant) As Long
    Dim Result As Long
    Result = LOAD_OK
    Dim FileNames() As Variant
    FileNames = UnfoldParamArray(DllNames)
    If UBound(FileNames) - LBound(FileNames) + 1 = 0 Then FileNames = this.Dlls.Keys
    Dim FileNameIndex As Long
    For FileNameIndex = LBound(FileNames) To UBound(FileNames)
        Result = Result And Free(FileNames(FileNameIndex))
    Next FileNameIndex
    FreeMultiple = Result
End Function

The DllManagerDemo example below illustrates how this class can be used and compares the usage patterns between system and user libraries. In this case, WinSQLite3 system library is used as a reference (see GetWinSQLite3VersionNumber). A call to a custom compiled SQLite library placed in the project folder demos the additional code necessary to make such a call (see GetSQLite3VersionNumber). In both cases, sqlite3_libversion_number routine, returning the numeric library version, is declared and called.

'@Folder "DllManager"
Option Explicit
Option Private Module

#If VBA7 Then
'''' System library
Private Declare PtrSafe Function winsqlite3_libversion_number Lib "WinSQLite3" Alias "sqlite3_libversion_number" () As Long
'''' User library
Private Declare PtrSafe Function sqlite3_libversion_number Lib "SQLite3" () As Long
#Else
'''' System library
Private Declare Function winsqlite3_libversion_number Lib "WinSQLite3" Alias "sqlite3_libversion_number" () As Long
'''' User library
Private Declare Function sqlite3_libversion_number Lib "SQLite3" () As Long
#End If


Private Type TDllManagerDemo
    DllMan As DllManager
End Type
Private this As TDllManagerDemo


Private Sub GetWinSQLite3VersionNumber()
    Debug.Print winsqlite3_libversion_number()
End Sub


Private Sub GetSQLite3VersionNumber()
    '''' Absolute or relative to ThisWorkbook.Path
    Dim DllPath As String
    DllPath = "Library\SQLiteCforVBA\dll\x32"
    
    SQLiteLoadMultipleArray DllPath
    Debug.Print sqlite3_libversion_number()
    Set this.DllMan = Nothing
End Sub


Private Sub SQLiteLoadMultipleArray(ByVal DllPath As String)
    Dim DllMan As DllManager
    Set DllMan = DllManager(DllPath)
    Set this.DllMan = DllMan
    Dim DllNames As Variant
    DllNames = Array( _
        "icudt68.dll", _
        "icuuc68.dll", _
        "icuin68.dll", _
        "icuio68.dll", _
        "icutu68.dll", _
        "sqlite3.dll" _
    )
    DllMan.LoadMultiple DllNames
End Sub


' ========================= '
' Additional usage examples '
' ========================= '
Private Sub SQLiteLoadMultipleParamArray()
    Dim RelativePath As String
    RelativePath = "Library\SQLiteCforVBA\dll\x32"
    
    Dim DllMan As DllManager
    Set DllMan = DllManager(RelativePath)
    
    DllMan.LoadMultiple _
        "icudt68.dll", _
        "icuuc68.dll", _
        "icuin68.dll", _
        "icuio68.dll", _
        "icutu68.dll", _
        "sqlite3.dll"
End Sub


Private Sub SQLiteLoad()
    Dim RelativePath As String
    RelativePath = "Library\SQLiteCforVBA\dll\x32"
    
    Dim DllMan As DllManager
    Set DllMan = DllManager(RelativePath)
    Dim DllNames As Variant
    
    DllNames = Array( _
        "icudt68.dll", _
        "icuuc68.dll", _
        "icuin68.dll", _
        "icuio68.dll", _
        "icutu68.dll", _
        "sqlite3.dll" _
    )
    
    Dim DllNameIndex As Long
    For DllNameIndex = LBound(DllNames) To UBound(DllNames)
        Dim DllName As String
        DllName = DllNames(DllNameIndex)
        DllMan.Load DllName, RelativePath
    Next DllNameIndex
End Sub

The source code is deposited into a GitHub repo

\$\endgroup\$
2
  • 2
    \$\begingroup\$ In your examples could you please include when and how you call the free methods, and how you might be using this class in conjunction with the code to actually call into the loaded DLL? It's hard to comment on the interface without seeing the context of the entire lifetime of instances of this class, not just their creation. \$\endgroup\$
    – Greedo
    Oct 4 at 10:16
  • 1
    \$\begingroup\$ Thank you, @Greedo for your pointers. I have updated the question to address your questions. Please note that the Class_Terminate destructor unloads the libraries. \$\endgroup\$
    – PChemGuy
    Oct 5 at 10:11

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.