User:Woozle/VB/Settings manager/source code

clsSettingAPI
This is an abstract class for translating between internal data and the string to actually save. It is implemented by and. 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
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 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 ' 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 ' 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