Woozle at 23:02, 1 January 2007

2007-01-01T23:02:31Z

New page

==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]].
<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>

← Older revision		Revision as of 23:23, 1 January 2007
Line 1:		Line 1:
			==Notes==
			* The "*API" classes are [[abstract class]]es 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==		==Code==
	===clsSettingAPI===		===clsSettingAPI===

User:Woozle/VB/Settings manager/source code - Revision history

Woozle: notes: api and xml (moved from overview page)

Woozle at 23:02, 1 January 2007

User:Woozle/VB/Settings manager/source code - Revision history

Woozle: notes: *api and *xml (moved from overview page)

Woozle at 23:02, 1 January 2007

Woozle: notes: api and xml (moved from overview page)