headerbanner

VBA - singleton

VBA sice nemá statické vlastnosti třídy a neumožňuje chránit konstruktor, ale s jistými omezeními i v něm jde vytvořit singleton, tedy třídu, která umožní vytvoření pouze jediné instance. Hodí se to například u připojení k databázi, protože využíváme stávajícího otevřeného připojení a nevytváříme zvláštní objekty při každém připojení znovu. (ODBC ovladač se sice zřejmě postará o využití existujícího připojení sám, i když mu vnucujeme nové, ale eliminace nových objektů přinejmenším šetří paměť. Navíc vzor je použitelný i pro mnoho dalších účelů, třeba pro konfigurační proměnné a pod.)

 

V každé třídě, kterou chceme omezit na singleton, potřebujeme pouze jediný řádek navíc:

Private Sub Class_Initialize()
 
 If Not Singleton.isCalled Then Singleton.errNew TypeName(Me)
End Sub
 

Jinak můžeme v kódu používat vše podle zvyklostí. O "zesingltonění" třídy se pak postará kód v pomocném "neviditelném" formuláři. Formulář je zvolen proto, že jde o objektový modul, objekt vzniká automaticky zahrnutím do projektu a nemusíme se starat o jeho vytvoření v programu.

Formulář a názvem "Singleton" obsahuje následující kód:

 
Private SingleInsts As Collection
Private instCount As Double
Public isCalled As Boolean
 
Private Sub UserForm_Initialize()
    Me.Hide
    Me.isCalled = False
End Sub
 
Private Function setInstance(name As String) As Object
    Dim Obj As Object
    On Error GoTo errline
    If SingleInsts Is Nothing Then Set SingleInsts = New Collection
    instCount = SingleInsts.Count
    ReDim singleNames(instCount + 1)
    Me.isCalled = True
    Select Case name
        Case "Factory"
            Set Obj = New Factory
        Case Else
            On Error GoTo 0
            Err.Raise vbObjectError + 700, Err.Source & "|" & Me.name & "." & "setInstance", name & " is not a classname"
            On Error GoTo errline
    End Select
    Me.isCalled = False
    SingleInsts.Add Obj, name
    Set setInstance = Obj
    Exit Function
errline:
    Err.Raise vbObjectError + 701, Err.Source & "|" & Me.name & "." & "setInstance", "Error by class name: " & name
End Function
 
Public Function getInstance(name As String) As Object
    On Error Resume Next
    If (SingleInsts(name) Is Nothing) And False Then
        'tudy pouze při chybě, tedy když neexistuje instance třídy name 
        Set getInstance = setInstance(name)
    Else
        Set getInstance = SingleInsts(name)
    End If
End Function
 
Public Function errNew(errstr As String)
    Err.Raise vbObjectError + 703, errstr & " you can not instatiate with New"
End Function
 
 
 
 

V kolekci SingleInsts jsou uchováváni "jedináčkové" a klíčová je funkce getInstance(), která objekt jako člena kolekce vytvoří (voláním setInstance), když ještě neexistuje, a vrací, když už jako instance třídy existuje. Vlastnost isCalled (z vnějšku dostupná jako Singleton.isCalled) hlídá, aby se objekt třídy nevytvářel pomocí new. Jediné, co kromě vložení inicializační funkce do modulu třídy ještě musíme udělat při definici dalšího singletonu, je úprava funkce setInstance(). Pokud chceme například vyrábět jedináčka třídy "novatrida" (jejíž kód je tedy ve stejnojmenném modulu třídy), rozšíříme select následovně:

Select Case name
     Case "Factory"
        Set Obj = New Factory
     Case "novatrida"
        Set Obj = New novatrida
     Case Else
        GoTo errline
End Select

To je v podstatě vše. Stačí tedy vytvořit v projektu formulář s názvem Singleton, do něj zkopírovat uvedený kód. Pak si na zkoušku vytvořte modul třídy(! - tedy ne standardní modul) s názvem "Factory" a do něj můžete vložit zkušební kód:

Private p As String
Public Property Let prop1(param1)
    p = param1
End Property
Public Property Get prop1() As Variant
    prop1 = p
End Property
 
Private Sub Class_Initialize()
    If Not Singleton.isCalled Then Singleton.errNew TypeName(Me)
End Sub

No a nakonec vytvořte standardní (neobjektový) modul a do něj vložte třeba následující kód, abyste si mohli práci vyzkoušet

Sub fo()
    On Error GoTo errline
    Singleton.getInstance("Factory").prop1 = 3
    'Set singl2 = New Factory '- error
    Set Singl2 = Singleton.getInstance("Factory") 'singl2=singl
    Singleton.getInstance("Factory").prop1 = 3
    Set Singl3 = Singleton.getInstance("Factory") 'singl3=singl
    Debug.Print Singl2.prop1 'print 3
    Debug.Print Singl3.prop1 'print 3
    Singleton.getInstance("Factory").prop1 = 4
    Debug.Print Singleton.getInstance("Factory").prop1 'print 4
    Debug.Print Singl2.prop1 'print 4
    Singl2.prop1 = 2
    Debug.Print Singl2.prop1 'print 2
    Debug.Print Singleton.getInstance("Factory").prop1 'print 2
Exit Sub
errline:
    MsgBox Err.Number & vbCrLf & Err.Source & vbCrLf & Err.Description
 
End Sub

Jiné řešení singletonu...