Class Server
Class Server
Option Explicit
Option Private Module
Private Const cModule As String = "modClassServer"
' Class Server Request Types
Enum csRequestType
csGet
csRmv
csSav
csClr
csLst
[_cs]
End Enum
Private Function ClassServer(ByVal csRequest As csRequestType, _
Optional ByVal sName As String, _
Optional ByRef oClass As Object) As Boolean
' Description:Performs various requests on the class container dictionary.
' Classes placed in ClassServer will persist as long as the
' workbook remains open, or until removed from ClassServer.
' While this was specifically designed to contain classes,
' this can hold anything.
' Inputs: csRequest Sav,Get,Remove, or Clear
' sName Name class instance was saved as
' oClass Class instance
' Outputs: Me Success/Failure
' oClass Class instance
' Requisites: *None
' Notes: This routine serves UI routines: GetCls, SavCls, RmvCls, and ClrCls
' It provides all error handling for the UIs
' It provides one place to manage classes and eliminates the need
' for a global variable
' Class names should be fully qualified (include workbook name)
' Example: ?SavCls(ThisWorkbook.Name & ":clsWorkbook", oClass)
' Date Ini Modification
' 07/07/14 CWH Initial Programming
' Declarations
Const cRoutine As String = "ClassServer"
Static oDic As Object 'Data Dictionary used as Class container
Dim v As Variant
' Error Handling Initialization
On Error GoTo ErrHandler
ClassServer = Failure
' Initialize variables
If oDic Is Nothing Then Set oDic = CreateObject("Scripting.Dictionary")
' Procedure
Select Case csRequest
Case Is = csSav: Set oDic(sName) = oClass
Case Is = csGet: If oDic.Exists(sName) Then Set oClass = oDic(sName)
Case Is = csRmv: If oDic.Exists(sName) Then oDic.Remove sName
Case Is = csClr: oDic.RemoveAll
Case Is = csLst: For Each v In oDic.Keys(): Debug.Print v: Next
End Select
ClassServer = Success
ErrHandler:
Select Case Err.Number
Case Is = NoError: 'Do nothing
Case Else:
Select Case DspErrMsg(cModule & "." & cRoutine)
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
Public Function SavCls(ByVal sSaveAs As String, _
ByVal oClass As Object) As Boolean
SavCls = ClassServer(csSav, sSaveAs, oClass)
End Function
Public Function GetCls(ByVal sSavedAs As String) As Object
ClassServer csGet, sSavedAs, GetCls
End Function
Public Function RmvCls(ByVal sSavedAs As String) As Boolean
RmvCls = ClassServer(csRmv, sSavedAs)
End Function
Public Function ClrCls() As Boolean
ClrCls = ClassServer(csClr)
End Function
Public Function LstCls() As Boolean
LstCls = ClassServer(csLst)
End Function