User:Woozle/VB/Settings manager/source code

from HTYP, the free directory anyone can edit if they can prove to me that they're not a spambot
Jump to navigation Jump to search

Notes

  • The "*API" classes are abstract classes which define the basic Settings API without actually doing anything.
  • The "*XML" classes implement the API classes using MSXML2 to load and save the data.

Code

clsSettingAPI

This is an abstract class for translating between internal data and the string to actually save. It is implemented by #clsSettingText and #xtForm. 

Option Explicit

' CLASS: clsSettingAPI
' PURPOSE: abstract class for saving a single item's settings
Public Name As String
Public Value As String
Public Sub Save(iNode As clsSettingsNodeAPI)
' abstract
End Sub
Public Sub Load(iNode As clsSettingsNodeAPI)
' abstract
End Sub

clsSettingsAPI

Option Explicit

' CLASS: clsSettingsAPI
' PURPOSE: abstract settings-saving class

Public Function Root() As clsSettingsNodeAPI
' ACTION: Return the root node
' USAGE: abstract; this is model code:
    Dim objRoot As clsSettingsNodeAPI
    
    Set objRoot = New clsSettingsNodeAPI
    objRoot.Init Me, Nothing
    Set Root = objRoot
End Function
Public Sub Load(iForce As Boolean)
' abstract
End Sub
Public Sub Save()
' abstract
End Sub
Private Sub Class_Initialize()
' abstract; sample code
    Me.Load False
End Sub
Private Sub Class_Terminate()
' abstract; sample code
    Me.Save
End Sub

clsSettingsNodeAPI

' CLASS: clsSettingsNodeAPI
' PURPOSE: set of values for clsSettingsAPI
' USAGE: Abstract

Option Explicit
Private objMain As clsSettingsAPI
Private objParent As clsSettingsNodeAPI
Friend Sub Init(iSettings As clsSettingsAPI, iParent As clsSettingsNodeAPI)
    Set objMain = iSettings
    Set objParent = iParent
End Sub
Public Property Get Name() As String
' abstract
End Property
Public Function Node(iName As String, iCreate As Boolean) As clsSettingsNodeAPI
' ACTION: Return the root node
' USAGE: abstract; this is model code:
    Dim objNode As clsSettingsNodeAPI
    
    Set objNode = New clsSettingsNodeAPI
' find subnode with name iName; initialize objNode with it (not Nothing)
    objNode.Init Me, Nothing
    Set Node = objNode
End Function
Public Function AddItem(iItem As clsSettingAPI) As clsSettingsNodeAPI
' ACTION: Add an item to the tree; return the item's node object
' abstract
End Function
Public Property Get ValueStored() As String
' ACTION: Returns the *stored* value (not the active value)
' abstract
End Property
Public Property Let ValueStored(iValue As String)
' ACTION: Sets the *stored* value (not the active value)
' abstract
End Property
Public Sub Load()
' abstract
End Sub
Public Sub Save()
' abstract
End Sub
Public Property Get ListNodes() As Scripting.Dictionary
' abstract
End Property

clsSettingsXML

Private strSection As String
Private strAppName As String
Private strFileSpec As String
Private xmlDoc As MSXML2.DOMDocument
Private objRoot As clsSettingsNodeXML
Private isLoaded As Boolean
Public Sub Init(Optional iSection As String = "", Optional iAppName As String = "")
    If iSection <> "" Then
        strSection = iSection
    End If
    If iAppName <> "" Then
        strAppName = iAppName
    End If
    
    strFileSpec = App.Path & "\" & App.Title & ".prefs.xml"
    isLoaded = False
End Sub
Public Function Root() As clsSettingsNodeAPI
' ACTION: Return the root node
'    Dim objRootSet As clsSettingText
    Dim xmlRoot As MSXML2.IXMLDOMNode
    
    If objRoot Is Nothing Then
 '       Set objRootSet = New clsSettingText
 '       objRootSet.Init strSection, ""
        Set objRoot = New clsSettingsNodeXML
        With Me.GetXMLDoc
            If .childNodes.Length = 0 Then
                Stop    ' this should never happen - GetXMLDoc is supposed to create the root node
            Else
                Set xmlRoot = .firstChild
            End If
        End With
        objRoot.InitRoot strSection, xmlRoot, Me
    End If
    Set Root = objRoot
End Function
Public Property Get FileSpec() As String
    FileSpec = strFileSpec
End Property
Public Property Let FileSpec(iSpec As String)
    strFileSpec = iSpec
End Property
Public Sub Load(iForce As Boolean)
' ACTION: Read settings data from file
    If iForce Or (Not Me.Loaded) Then
        Me.GetXMLDoc.Load Me.FileSpec
'        Set xmlDoc = Nothing    ' loading the document clears all nodes
        isLoaded = True
    End If
End Sub
Public Sub Save()
'    Dim objNode As clsSettingsNodeXML
    
'    Set objNode = Me.Root
'    objNode.Save
    Me.GetXMLDoc.Save Me.FileSpec
    isLoaded = True
End Sub
Public Function Loaded() As Boolean
    Loaded = isLoaded
End Function
Friend Function GetXMLDoc() As MSXML2.DOMDocument
    Dim xmlRoot As MSXML2.IXMLDOMNode
    
    ' create document if needed
    If xmlDoc Is Nothing Then
        Set xmlDoc = New MSXML2.DOMDocument
    End If
    
    ' create root node if needed
    If xmlDoc.childNodes.Length = 0 Then
        With xmlDoc
        ' create the root node
            Set xmlRoot = .createNode(NODE_ELEMENT, strSection, "")
            .appendChild xmlRoot
        End With
    End If
    Set GetXMLDoc = xmlDoc
End Function
Private Sub Class_Initialize()
    strSection = "settings" ' default
    strAppName = App.EXEName
End Sub
Private Sub clsSettingsAPI_Load(iForce As Boolean)
    Me.Load iForce
End Sub
Private Function clsSettingsAPI_Root() As clsSettingsNodeAPI
    clsSettingsAPI_Root = Me.Root
End Function
Private Sub clsSettingsAPI_Save()
    Me.Save
End Sub
===clsSettingsNodeXML===
<pre>
Option Explicit

Implements clsSettingsNodeAPI

Private strName As String
Private objMain As clsSettingsXML
Private objParent As clsSettingsNodeXML
Public XMLNode As MSXML2.IXMLDOMNode
Private objItem As clsSettingAPI
Private lstNodes As Scripting.Dictionary      ' list of sub-nodes
Private lstXMLs As Scripting.Dictionary     ' list of XML sub-nodes (refresh before using)
Friend Sub Init(iItem As clsSettingAPI, iXML As MSXML2.IXMLDOMNode, iParent As clsSettingsNodeAPI)
    Set objItem = iItem
    Set objParent = iParent
    Me.InitRoot iItem.Name, iXML, objParent.Main
End Sub
Friend Sub InitRoot(iName As String, iXML As MSXML2.IXMLDOMNode, iMain As clsSettingsXML)
' USAGES: (1) Internally, and (2) for clsSettingsXML to initialize root node only
    strName = iName
    Set XMLNode = iXML
    Set objMain = iMain
End Sub
Friend Sub InitHolder(iName As String, iXML As MSXML2.IXMLDOMNode, iParent As clsSettingsNodeXML)
' USAGE: For initializing a node when we don't yet know what Item it will have
    Me.InitRoot iName, iXML, iParent.Main
    Set objParent = iParent
    Set objItem = Nothing   ' this will be set later
End Sub
Friend Property Set Item(iItem As clsSettingAPI)
    Set objItem = iItem
End Property
Friend Property Get Item() As clsSettingAPI
    Set Item = objItem
End Property
Friend Property Get Main() As clsSettingsXML
    Set Main = objMain
End Property
Friend Property Set Main(iDoc As clsSettingsXML)
    Set objMain = iDoc
End Property
Public Function Node(iName As String, iCreate As Boolean) As clsSettingsNodeXML
' ACTION: Return the node with the given name
    Dim objNode As clsSettingsNodeXML
    
'    Set objNode = New clsSettingsNodeXML
' find subnode with name iName; initialize objNode with it (not Nothing)
    With Me.ListNodes
        If .Exists(iName) Then
            Set objNode = .Item(iName)
        Else
            If iCreate Then
                Set objNode = New clsSettingsNodeXML
                objNode.InitHolder iName, MakeXML(iName), Me
            Else
                Set objNode = Nothing
            End If
        End If
    End With
    Set Node = objNode
End Function
Public Property Get Name() As String
    Name = strName
End Property
Public Property Get ValueStored() As String
' ACTION: Returns the *stored* value (not the active value)
    If Not (XMLNode Is Nothing) Then
        ValueStored = XMLNode.Text
    End If
End Property
Public Property Let ValueStored(iValue As String)
' ACTION: Sets the *stored* value (not the active value)
    If XMLNode Is Nothing Then
        Stop    ' does this ever happen?
    End If
    XMLNode.Text = iValue
End Property
Public Property Get ValueActive() As String
    If Not (objItem Is Nothing) Then
        ValueActive = objItem.Value
    End If
End Property
Public Property Let ValueActive(iValue As String)
' ACTION: Sets the *stored* value (not the active value)
    If Not (objItem Is Nothing) Then
        objItem.Value = iValue
    End If
End Property
Public Sub Load()
' ACTION: Read values from the XML DOM tree and stash them in clsSettingAPI objects
    Dim xmlThis As MSXML2.IXMLDOMNode
    Dim objSub As clsSettingsNodeXML
    
' 1. Look through the document and pull out values into the value list; save pointer to each node found
    Set xmlThis = XMLNode.firstChild
    Do While Not (xmlThis Is Nothing)
        With xmlThis
            If Not Me.ListNodes.Exists(.nodeName) Then
'            ' this block duplicates code in me.List; should probably put it in a subroutine
'                Set objSub = New clsSettingsNodeXML
'                objSub.InitHolder .baseName, xmlThis, Me
'                lstNodes.Add .baseName, Nothing
                AddHolder xmlThis
            End If
            Set objSub = Me.Node(.nodeName, False)
            objSub.ValueActive = .Text
        End With
        Set xmlThis = xmlThis.nextSibling
    Loop
' 2. Go through the list and call Load() recursively
    LoadSub
End Sub
Private Sub AddHolder(iXML As MSXML2.IXMLDOMNode)
    Dim objSub As clsSettingsNodeXML
    Dim strName As String
    
    strName = iXML.nodeName
    Set objSub = New clsSettingsNodeXML
    objSub.InitHolder strName, iXML, Me
    lstNodes.Add strName, objSub
End Sub
Private Sub LoadSub()
    Dim idxSub As Long
    Dim objNode As clsSettingsNodeXML
    
    For idxSub = 0 To Me.ListNodes.Count - 1
        Set objNode = Me.ListNodes.Items(idxSub)
        objNode.Load
    Next
End Sub
Public Sub Save()
' ACTION:
    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlParent As MSXML2.IXMLDOMNode
    Dim xmlThis As MSXML2.IXMLDOMNode
    Dim strName As String
    
    Set xmlDoc = objMain.GetXMLDoc
'    ' there doesn't seem to be any way to find out if a child node already exists,
'    '   so for now we just kill them all.
'    Set xmlThis = xmlNode.firstChild
'    Do While Not (xmlThis Is Nothing)
'        Set xmlNext = xmlThis.nextSibling
'        xmlNode.removeChild xmlThis
'        Set xmlThis = xmlNext
'    Loop
'    If xmlSelf.childNodes.Length <> 0 Then Stop

    If Not (objItem Is Nothing) Then
        objItem.Save Me ' tell the object to save itself, in case it has any sub-items
'        Me.XMLNode.Text = objItem.Value
    End If
    ' recursively repeat for all sub-nodes:
    SaveSub
End Sub
Private Sub SaveSub()
    Dim idxSub As Long
'    Dim objNode As clsSettingAPI
'    Dim objNode As Object
    Dim objNode As clsSettingsNodeXML
    Dim strKey As String
    Dim xmlThis As MSXML2.IXMLDOMNode
    
    Set lstXMLs = ListXMLs
    With Me.ListNodes
        For idxSub = 0 To .Count - 1
            Set objNode = .Items(idxSub)
            strKey = objNode.Name
            If Not lstXMLs.Exists(strKey) Then
            ' if an XML node does not already exist, create it and add it to the parent node (i.e. Me)
                Set xmlThis = objMain.GetXMLDoc.createNode(NODE_ELEMENT, strKey, "")
' Don't save the data here; that's done in objNode.Save()
'                xmlThis.Text = objNode.ValueActive
                Me.XMLNode.appendChild xmlThis
                Debug.Assert Not (xmlThis.parentNode Is Nothing)
            End If
            objNode.Save
            
'            Debug.Print "NAME=" & strName
'            Set xmlText = xmlDoc.createTextNode(.Items(intItem))
'            xmlThis.appendChild xmlText
        Next
    End With
End Sub
Friend Property Get ListXMLs() As Scripting.Dictionary
' ACTION: get a list of XML subnodes
' maybe this is doing more processing than needed...
    Dim xmlKid As MSXML2.IXMLDOMNode
    
    Set lstXMLs = New Scripting.Dictionary
    Set xmlKid = Me.XMLNode.firstChild
    Do Until xmlKid Is Nothing
        lstXMLs.Add xmlKid.nodeName, xmlKid
        Set xmlKid = xmlKid.nextSibling
    Loop
    Set ListXMLs = lstXMLs
End Property
'Friend Function GetXMLNode() As MSXML2.IXMLDOMNode
'    Dim xmlDoc As MSXML2.DOMDocument
'    Dim xmlRoot As MSXML2.IXMLDOMNode
'    Dim xmlNode As MSXML2.IXMLDOMNode
'
'    Set xmlDoc = objMain.GetXMLDoc
'
'    If objParent Is Nothing Then
'        ' need root node
'        If xmlDoc.childNodes.Length = 0 Then
'            ' none exists yet; create it:
'            Set xmlNode = xmlDoc.createNode(NODE_ELEMENT, Me.Name, "")
'            xmlDoc.appendChild xmlNode
'        Else
'            Set xmlNode = xmlDoc.firstChild
'        End If
'    Else
'        ' create non-root node
'        Set xmlNode = xmlDoc.createNode(NODE_ELEMENT, Me.Name, "")
'        Set xmlRoot = objParent.GetXMLNode
'        xmlRoot.appendChild xmlNode
'    End If
'
'    Set GetXMLNode = xmlNode
'End Function
Public Property Get ListNodes() As Scripting.Dictionary
    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlRoot As MSXML2.IXMLDOMElement
    Dim xmlThis As MSXML2.IXMLDOMNode
'    Dim objNew As clsSettingsNodeXML

    If lstNodes Is Nothing Then
' What is often happening at this point is that the XML document has been loaded, but items have not been assigned.
' So we have to set up item-nodes without knowing what objects to assign to them.

' 2006-02-12 actually, this list should never be rebuilt from the XML tree. For one thing, that tree has stuff we don't want
'   to put in the nodes list. For another, this list is maintained explicitly.
'   Correction: unfortunately, we need to be able to list items not explicitly added, for things like dynamic lists
        Set lstNodes = New Scripting.Dictionary ' create the list object
        If Not (Me.XMLNode Is Nothing) Then
            If Me.XMLNode.nodeType <> NODE_TEXT Then
            ' text nodes get saved along with their parent
                For Each xmlThis In Me.XMLNode.childNodes
                    With xmlThis
    '                    Set objNew = New clsSettingsNodeXML
    '                    objNew.InitHolder .baseName, xmlThis, Me
    '                    lstNodes.Add .nodeName, .Text
                        AddHolder xmlThis
                    End With
                Next
            End If
        End If
    End If
    Set ListNodes = lstNodes
End Property
'Public Property Get Exists(iName As String)
'    Exists = Me.ListItems.Exists(iName)
'End Property
Public Sub LoadTextBox(iCtrl As TextBox, Optional iName As String = "")
    Dim strName As String
    
    If iName = "" Then
        strName = iCtrl.Name
    Else
        strName = iName
    End If
    If Me.ListNodes.Exists(strName) Then
        iCtrl.Text = Me.Node(strName, False).ValueStored
    End If
End Sub
Public Sub SaveTextBox(iCtrl As TextBox, Optional iName As String = "")
    Dim strName As String
    Dim strValue As String
    
    If iName = "" Then
        strName = iCtrl.Name
    Else
        strName = iName
    End If
    strValue = iCtrl.Text
    Me.Node(strName, True).ValueStored = strValue
End Sub
Public Sub LoadChkBox(iCtrl As CheckBox, Optional iName As String = "")
    Dim strName As String
    Dim strValue As String
    
    If iName = "" Then
        strName = iCtrl.Name
    Else
        strName = iName
    End If
    strValue = Me.Node(strName, False).ValueStored
    If strValue <> "" Then
        If strValue = "0" Then
            iCtrl.Value = vbUnchecked
        Else
            iCtrl.Value = vbChecked
        End If
    End If
End Sub
Public Sub SaveChkBox(iCtrl As CheckBox, Optional iName As String = "")
    Dim strName As String
    Dim strValue As String
    Dim objNode As clsSettingsNodeAPI
    
    If iName = "" Then
        strName = iCtrl.Name
    Else
        strName = iName
    End If
    Set objNode = Me.Node(strName, True)
    If iCtrl.Value Then
        strValue = "1"
    Else
        strValue = "0"
    End If
    objNode.ValueStored = strValue
End Sub
Public Sub LoadCombo(iCombo As ComboBox, Optional iName As String = "")
    Dim strName As String
    Dim strValue As String
    Dim idxValue As Long
    
    If iName = "" Then
        strName = iCombo.Name
    Else
        strName = iName
    End If
    
    strValue = Me.Node(strName, False).ValueStored
    If IsNumeric(strValue) Then
        idxValue = CLng(strValue)
        If idxValue < iCombo.ListCount Then
           iCombo.ListIndex = CLng(strValue)
        End If
    End If
End Sub
Public Sub SaveCombo(iCombo As ComboBox, Optional iName As String = "")
    Dim strName As String
    Dim strValue As String
    
    If iName = "" Then
        strName = iCombo.Name
    Else
        strName = iName
    End If
    
    strValue = CStr(iCombo.ListIndex)
    Me.Node(strName, True).ValueStored = strValue
End Sub
Private Function MakeXML(iName As String) As MSXML2.IXMLDOMNode
    Dim objXML As MSXML2.IXMLDOMNode
        
    If Me.ListXMLs.Exists(iName) Then
        Set objXML = lstXMLs.Item(iName)
    Else
        Set objXML = objMain.GetXMLDoc.createNode(NODE_ELEMENT, iName, "")
        Me.XMLNode.appendChild objXML
    End If
    Set MakeXML = objXML
End Function
Private Function clsSettingsNodeAPI_AddItem(iItem As clsSettingAPI) As clsSettingsNodeAPI
    Dim objNode As clsSettingsNodeXML
    Dim objXML As MSXML2.IXMLDOMNode

    If Me.XMLNode Is Nothing Then Stop

    If Me.ListNodes.Exists(iItem.Name) Then
        Set objNode = lstNodes.Item(iItem.Name)
        Set objNode.Item = iItem
    Else
        Set objNode = New clsSettingsNodeXML
        Set objXML = MakeXML(iItem.Name)
        objNode.Init iItem, objXML, Me
        lstNodes.Add iItem.Name, objNode
    End If
End Function
Private Property Get clsSettingsNodeAPI_ListNodes() As Scripting.IDictionary
    Set clsSettingsNodeAPI_ListNodes = Me.ListNodes
End Property
Private Sub clsSettingsNodeAPI_Load()
' ACTION:
'   - Load the current node's value
'   - Iterate through children and call Load() for each
    Dim objNode As clsSettingsNodeXML
    Dim objKid As clsSettingAPI
    Dim idxKid As Long

    If Not (objItem Is Nothing) Then
        objItem.Load Me
    End If
    For idxKid = 0 To Me.ListNodes.Count - 1
        Set objNode = lstNodes.Items(idxKid)
        Set objKid = objNode.Item
        objKid.Load objNode
    Next
End Sub
Private Property Get clsSettingsNodeAPI_Name() As String
    clsSettingsNodeAPI_Name = Me.Name
End Property
Private Function clsSettingsNodeAPI_Node(iName As String, iCreate As Boolean) As clsSettingsNodeAPI
    Set clsSettingsNodeAPI_Node = Me.Node(iName, iCreate)
End Function
Private Sub clsSettingsNodeAPI_Save()
    Me.Save
End Sub
Private Property Let clsSettingsNodeAPI_ValueStored(RHS As String)
    Me.ValueStored = RHS
End Property
Private Property Get clsSettingsNodeAPI_ValueStored() As String
    clsSettingsNodeAPI_ValueStored = Me.ValueStored
End Property

clsSettingText

An implementation of #clsSettingAPI 

Option Explicit

' CLASS: clsSettingText
' PURPOSE: generic clsSettingAPI class for storing a text value
'   without needing an associated control

Implements clsSettingAPI

Private strName As String
Private strVal As String
Public Sub Init(iName As String, iVal As String)
    strName = iName
    strVal = iVal
End Sub
Private Sub clsSettingAPI_Load(iNode As clsSettingsNodeAPI)
    strVal = iNode.ValueStored
End Sub
Private Property Let clsSettingAPI_Name(ByVal RHS As String)
    strName = RHS
End Property
Private Property Get clsSettingAPI_Name() As String
    clsSettingAPI_Name = strName
End Property
Private Sub clsSettingAPI_Save(iNode As clsSettingsNodeAPI)
    iNode.ValueStored = strVal
End Sub
Private Property Let clsSettingAPI_Value(ByVal RHS As String)
    strVal = RHS
End Property
Private Property Get clsSettingAPI_Value() As String
    clsSettingAPI_Value = strVal
End Property

xtForm

Implementation of #clsSettingAPI 

' CLASS: xtForm
' PURPOSE: extended form functionality
' HISTORY:
'   1999.12.06 - NJS - adapted from Forms.bas
'   2001.01.03 - NJS - modified to use clsConfigReg for storing position
'   2006-01-22 - Wzl - modified to use clsSettingsAPI for storing position

Implements clsSettingAPI

Public WithEvents Form As Form
Public doSaveSize As Boolean
Public doAutoSave As Boolean

Private strPos As String
'Private objSet As clsSettingsNodeAPI
Private strName As String

Option Explicit
Public Sub Init(iForm As Form)
    Set Form = iForm
    doSaveSize = (iForm.BorderStyle = vbSizable) Or (iForm.BorderStyle = vbSizableToolWindow)
'    Set objSet = iSettings
'    Me.LoadPos
    strName = iForm.Name
End Sub
Public Property Let Pos(istr As String)
    strPos = istr
    If Me.Form.Visible Then Me.PlaceForm
End Property
Public Property Get Pos() As String
' ACTION: return a string specifying the given form's size and position
    Dim ostr As String
    Dim can_size As Boolean
    
    With Me.Form
        If .WindowState <> vbNormal Then
            .WindowState = vbNormal ' so dimensions are meaningful when we read them
        End If
        ostr = .Left & " " & .Top
        If doSaveSize Then
            ostr = ostr & " " & .Width & " " & .Height
        End If
    End With
    Pos = ostr
End Property
'Public Sub Reveal()
'' ACTION: show the given form, and make sure it's not minimized.
'    With Me.Form
'        .Show
'        If .WindowState = vbMinimized Then
'            .WindowState = vbNormal
'        End If
'        LoadPos ' restore saved position
'    End With
'End Sub
'Public Sub LoadPos(Optional iKey As String)
'    If iKey = "" Then
'        iKey = Form.Name
'    End If
'    Me.Pos = objSet.Value(iKey)
'    PlaceForm
'End Sub
'Public Sub SavePos(Optional iKey As String)
'' PURPOSE: saves the given form's position to the registry
'    With Me.Form
'        If iKey = "" Then
'            iKey = .Name
'        End If
'        If .Visible And (.WindowState <> vbMinimized) Then
'            objSet.Value(iKey) = Me.Pos
'        End If
'    End With
'End Sub
Public Sub PlaceForm()
' ACTION: set the given form's size and position from the stored string
    Dim oarr As Variant
    Dim can_size As Boolean
    
    If strPos = "" Then
    ' use default position: center in screen
        With Me.Form
            .Left = (Screen.Width - .Width) / 2
            .Top = (Screen.Height - .Height) / 2
        End With
    Else
    ' use stored position (and size if applicable)
        oarr = Split(strPos, " ")
        With Form
            .Left = oarr(0)
            .Top = oarr(1)
            If .Left > Screen.Width Then
                .Left = Screen.Width - .Width
            End If
            If .Top > Screen.Height Then
                .Top = Screen.Height - .Height
            End If
            If doSaveSize And (UBound(oarr) > 1) Then
                .Width = oarr(2)
                .Height = oarr(3)
            End If
        End With
    End If
End Sub
Private Sub clsSettingAPI_Load(iNode As clsSettingsNodeAPI)
    strPos = iNode.ValueStored
    PlaceForm
End Sub
Private Property Let clsSettingAPI_Name(ByVal RHS As String)
    strName = RHS
End Property
Private Property Get clsSettingAPI_Name() As String
    clsSettingAPI_Name = strName
End Property
Private Sub clsSettingAPI_Save(iNode As clsSettingsNodeAPI)
    iNode.ValueStored = Me.Pos
End Sub
Private Property Let clsSettingAPI_Value(ByVal RHS As String)
    strPos = RHS
    PlaceForm
End Property
Private Property Get clsSettingAPI_Value() As String
    clsSettingAPI_Value = Me.Pos
End Property
'Private Sub Form_Activate()
' EVENT: runs the first time the form is shown
'    Me.PlaceForm
'End Sub
Private Sub Form_Deactivate()
    strPos = Me.Pos ' get new position
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' This is redundant; xtForm also handles this
'    If doAutoSave Then
'        Me.SavePos
'    End If
End Sub

xtListBox

Implementation of #clsSettingAPI 

' CLASS: xtListBox
' PURPOSE: extended functionality for ListBox control
' REQUIRES: xtListItems.cls, xtListItem.cls, property let/get AppSetting(Name)
Option Explicit
Implements clsSettingAPI

Public Event ItemChosen(oKey As Long)
Public Event ItemChecked(oKey As Long)

'Public Config As clsSettingsNodeAPI

'local variable(s) to hold property value(s)
Private strName As String
Private WithEvents ctrlList As ListBox 'local copy
Private WithEvents ctrlForm As Form
Private lstItems As Scripting.Dictionary
Private doDataSave As Boolean
Private intNewItem As Long
Public Sub Init(iList As ListBox, Optional iDataSave As Boolean = True)
    Set ctrlList = iList
    Set ctrlForm = iList.Parent
'    Set Config = iConfig
    Set lstItems = New Scripting.Dictionary
    doDataSave = iDataSave
    With ctrlList
        strName = .Parent.Name & "." & .Name
    End With
End Sub
Public Property Get List() As Scripting.Dictionary
    Set List = lstItems
End Property
Public Sub Add(iText As String, Optional iObj As Object)
' NOTES:
'   1. Add object to list
'   2. Add text to listbox, with ItemData pointer to list
    With ctrlList
        intNewItem = intNewItem + 1
        .AddItem iText
        .ItemData(.NewIndex) = intNewItem
        lstItems.Add intNewItem, iObj
    End With
End Sub
Public Sub Clear()
    ctrlList.Clear
    lstItems.RemoveAll
End Sub
Public Property Get SelectedItem() As Object
' to be written
End Property
Public Function SelectCount() As Integer
    SelectCount = ctrlList.SelCount
End Function
Public Sub ClearSelection()
' PURPOSE: removes any selections from the control
    Dim idxList As Long, qtyList As Long
    
    qtyList = ctrlList.ListCount
    For idxList = 1 To qtyList
        ctrlList.Selected(idxList) = False
    Next
End Sub
Public Sub DelSelected()
' ACTION: Delete selected items from the list
    Dim idxList As Long, qtyList As Long
    Dim idxDel As Long
    
    qtyList = Me.List.Count
    For idxList = qtyList - 1 To 0 Step -1
        ' find the item's key in the stored list
        idxDel = lstItems.Keys(idxList)
        If ctrlList.Selected(idxList) Then
            ' delete item from the stored list
            lstItems.Remove idxDel
            ' delete item from the control
            ctrlList.RemoveItem idxList
        End If
    Next
End Sub
Public Sub KeyDown(KeyCode As Integer, Shift As Integer)
'' PURPOSE: define additional standard behavior for non-ASCII key presses
'' ACTION: Shift-Insert copies list contents to clipboard
'    If ((KeyCode = vbKeyInsert) And (Shift & &H1)) Then
'        ClipCopy
'    End If
End Sub
Private Sub clsSettingAPI_Load(iNode As clsSettingsNodeAPI)
' ACTION: Load current selection and, if applicable, list data
    Dim qtyItem As Long
    Dim idxItem As Long
    Dim objNode As clsSettingsNodeAPI
    Dim strVal As String
    
'    Me.Value = iNode.ValueStored
    ' check for saved data list
    qtyItem = iNode.ListNodes.Count
    ' load data, if there is any
    For idxItem = 0 To qtyItem - 1
        Set objNode = iNode.ListNodes.Items(idxItem)
        strVal = objNode.ValueStored
        If objNode.Name = "selected" Then
            Me.Value = objNode.ValueStored
        Else
            If strVal <> "" Then
            ' klugefix
                If Not Me.List.Exists(strVal) Then
                    Me.Add strVal
                End If
            End If
        End If
    Next
End Sub
Private Property Let clsSettingAPI_Name(ByVal RHS As String)
    strName = RHS
End Property
Private Property Get clsSettingAPI_Name() As String
    clsSettingAPI_Name = strName
End Property
Private Sub clsSettingAPI_Save(iNode As clsSettingsNodeAPI)
    Dim idxItem As Long
    Dim objNode As clsSettingsNodeAPI
            
    Set objNode = iNode.Node("selected", True)
    objNode.ValueStored = Me.Value
    If doDataSave Then
        For idxItem = 0 To Me.List.Count - 1
            Set objNode = iNode.Node("line-" & CStr(idxItem), True)
            objNode.ValueStored = ctrlList.List(idxItem)
        Next
    End If
End Sub
Public Property Let Value(iValue As String)
    Dim xtsVal As xtString
    Dim idxSel As Long
    Dim strSel As String
    
    Set xtsVal = New xtString
    
    xtsVal.Value = iValue   ' data is list of selected items, by index
    ' parse data
    strSel = xtsVal.FindFirst
    Do While xtsVal.IsFound
        If IsNumeric(strSel) Then
            idxSel = CLng(strSel)
            ctrlList.Selected(idxSel) = True
        End If
        strSel = xtsVal.FindNext
    Loop
End Property
Public Property Get Value() As String
    Dim strSel As String
    Dim idxItem As Long
    
' debugging:
'    If Me.List.Count <> ctrlList.ListCount Then Stop

    For idxItem = 0 To ctrlList.ListCount - 1
        If ctrlList.Selected(idxItem) Then
            strSel = strSel & " " & idxItem
        End If
    Next
    Value = strSel
End Property
Private Property Let clsSettingAPI_Value(ByVal RHS As String)
    Me.Value = RHS
End Property
Private Property Get clsSettingAPI_Value() As String
    clsSettingAPI_Value = Me.Value
End Property
Private Sub ctrlList_Click()
    Dim intLine As Integer
    Dim intKey As Long

    intLine = ctrlList.ListIndex
    intKey = ctrlList.ItemData(intLine)
    If intKey Then
        RaiseEvent ItemChosen(intKey)
    End If
End Sub
Private Sub ctrlList_ItemCheck(Item As Integer)
    Dim intKey As Long

    If Me.List.Exists(Item) Then
        intKey = ctrlList.ItemData(Item)
        RaiseEvent ItemChecked(intKey)
    End If
End Sub
Retrieved from "https://htyp.org/mw/index.php?title=User:Woozle/VB/Settings_manager/source_code&oldid=6345"