Difference between revisions of "User:Woozle/VB/Settings manager"

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
 
(→‎Code: moved code to separate page)
Line 9: Line 9:
 
Items deleted from the saver-list may still be saved; something inside the XML objects is remembering them. You have to destroy the main Setting object and rebuild it at save-time in order to prevent this from happening. Fortunately, this doesn't seem to slow anything down noticeably.
 
Items deleted from the saver-list may still be saved; something inside the XML objects is remembering them. You have to destroy the main Setting object and rebuild it at save-time in order to prevent this from happening. Fortunately, this doesn't seem to slow anything down noticeably.
 
==Code==
 
==Code==
−
===clsSettingAPI===
+
* [[User:Woozle/VB/Settings manager/sample code|sample code]]: how to use the class collection
−
This is an abstract class for translating between internal data and the string to actually save. It is implemented by [[#clsSettingText]] and [[#xtForm]].
+
* [[User:Woozle/VB/Settings manager/source code|source code]]: the classes themselves
−
<pre>
 
−
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
 
−
</pre>
 
−
===clsSettingsAPI===
 
−
<pre>
 
−
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
 
−
</pre>
 
−
===clsSettingsNodeAPI===
 
−
<pre>
 
−
' 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
 
−
</pre>
 
−
===clsSettingsXML===
 
−
<pre>
 
−
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
 
−
</pre>
 
−
===clsSettingText===
 
−
An implementation of [[#clsSettingAPI]]
 
−
<pre>
 
−
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
 
−
</pre>
 
−
===xtForm===
 
−
Implementation of [[#clsSettingAPI]]
 
−
<pre>
 
−
' 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
 
−
</pre>
 
−
===xtListBox===
 
−
Implementation of [[#clsSettingAPI]]
 
−
<pre>
 
−
' 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
 
−
</pre>
 

Revision as of 23:05, 1 January 2007

Overview

This is a set of classes for automating the loading and saving of user settings in a VB application. It's not as fully-developed as the ones I wrote in C++, but it seems to have gotten to the point of being usable.

The settings are saved in XML format, courtesy of Microsoft's baffling and largely undocumented MSXML2 ActiveX interface from the "Microsoft XML, v3.0" library (filename is c:\windows\system\MSXML3.DLL), although the classes are intended to be pluggable on both ends (you should be able to swap out the XML code for code that handles other formats, as well as being able to add "savers" for more data types).

  • 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.

Bugs

Items deleted from the saver-list may still be saved; something inside the XML objects is remembering them. You have to destroy the main Setting object and rebuild it at save-time in order to prevent this from happening. Fortunately, this doesn't seem to slow anything down noticeably.

Code

Retrieved from "https://htyp.org/mw/index.php?title=User:Woozle/VB/Settings_manager&oldid=6341"