VB5 XML Property Bag DLL and Demonstration (28K)
VB6 XML Property Bag DLL and Demonstration (28K)
21 Mar 2000
First Posted
vbAccelerator - Contents of code file: Test_frmMain.frm
VERSION 5.00
Begin VB.Form frmMain
Caption = "XML Property Bag Demonstration"
ClientHeight = 4455
ClientLeft = 2490
ClientTop = 2325
ClientWidth = 8430
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4455
ScaleWidth = 8430
Begin VB.CommandButton cmdClear
Caption = "&Clear"
Height = 375
Left = 60
TabIndex = 23
Top = 4020
Width = 1215
End
Begin VB.TextBox txtZipCode
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 13
Top = 3480
Width = 1275
End
Begin VB.TextBox txtCity
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 12
Top = 3120
Width = 3075
End
Begin VB.TextBox txtState
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 11
Top = 2760
Width = 3075
End
Begin VB.TextBox txtAddress2
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 10
Top = 2400
Width = 3075
End
Begin VB.TextBox txtAddress1
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 9
Top = 2040
Width = 3075
End
Begin VB.ComboBox cboAddresses
Height = 315
Left = 1020
Style = 2 'Dropdown List
TabIndex = 8
Top = 1560
Width = 1275
End
Begin VB.TextBox txtBirthday
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 7
Top = 1080
Width = 3075
End
Begin VB.TextBox txtSurname
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 6
Top = 720
Width = 3075
End
Begin VB.TextBox txtFirstName
BackColor = &H8000000F&
Height = 315
Left = 1020
Locked = -1 'True
TabIndex = 5
Top = 360
Width = 3075
End
Begin VB.CommandButton cmdFromXML
Caption = "<< &Restore"
Height = 375
Left = 4260
TabIndex = 2
Top = 4020
Width = 1395
End
Begin VB.CommandButton cmdToXML
Caption = "&Save >>"
Height = 375
Left = 2640
TabIndex = 1
Top = 4020
Width = 1395
End
Begin VB.TextBox txtXML
BeginProperty Font
Name = "Lucida Console"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 3495
Left = 4260
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 0
Top = 300
Width = 4155
End
Begin VB.Label lblInfo
Caption = "&Zip"
Height = 195
Index = 10
Left = 60
TabIndex = 22
Top = 3540
Width = 915
End
Begin VB.Label lblInfo
Caption = "&City"
Height = 195
Index = 9
Left = 60
TabIndex = 21
Top = 3180
Width = 915
End
Begin VB.Label lblInfo
Caption = "&State"
Height = 195
Index = 8
Left = 60
TabIndex = 20
Top = 2820
Width = 915
End
Begin VB.Label lblInfo
Caption = "Address &2"
Height = 195
Index = 7
Left = 60
TabIndex = 19
Top = 2460
Width = 915
End
Begin VB.Label lblInfo
Caption = "Address &1"
Height = 195
Index = 6
Left = 60
TabIndex = 18
Top = 2100
Width = 915
End
Begin VB.Label lblInfo
Caption = "A&ddresses"
Height = 195
Index = 5
Left = 60
TabIndex = 17
Top = 1620
Width = 915
End
Begin VB.Label lblInfo
Caption = "&Birthday"
Height = 195
Index = 4
Left = 60
TabIndex = 16
Top = 1140
Width = 915
End
Begin VB.Label lblInfo
Caption = "&Surname"
Height = 195
Index = 3
Left = 60
TabIndex = 15
Top = 780
Width = 915
End
Begin VB.Label lblInfo
Caption = "&First Name"
Height = 195
Index = 2
Left = 60
TabIndex = 14
Top = 420
Width = 915
End
Begin VB.Label lblInfo
Caption = "Class Contents:"
Height = 195
Index = 1
Left = 60
TabIndex = 4
Top = 60
Width = 4095
End
Begin VB.Label lblInfo
Caption = "Property Bag Contents:"
Height = 195
Index = 0
Left = 4260
TabIndex = 3
Top = 60
Width = 4095
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_oPerson As New Person
Private Sub ShowPerson()
Dim i As Long
txtFirstName = m_oPerson.FirstName
txtSurname = m_oPerson.LastName
txtBirthday = m_oPerson.Birthday
cboAddresses.Clear
For i = 1 To m_oPerson.Addresses.Count
cboAddresses.AddItem "Address " & i
Next i
If cboAddresses.ListCount > 0 Then
cboAddresses.Enabled = True
cboAddresses.ListIndex = 0
Else
cboAddresses.Enabled = False
cboAddresses_Click
End If
End Sub
Private Function NiceXML(sXML As String) As String
Dim iOpenPos As Long
Dim iClosePos As Long
Dim iLastPos As Long
Dim iLevel As Long
Dim sLevelSpace As String
Dim sOut As String
' SPM: this is quick & dirty, it could fail on CDATA sections...
' to do it properly, use MSXML to enum the nodes instead.
iLastPos = 1
iOpenPos = InStr(iLastPos, sXML, "<")
If iOpenPos > 0 Then
If iOpenPos > 1 Then
sOut = sOut & Left$(sXML, iOpenPos)
End If
Do
iClosePos = InStr(iOpenPos, sXML, ">")
If iClosePos > 0 Then
If (Mid$(sXML, iOpenPos + 1, 1) = "/") Then
iLevel = iLevel - 1
If iLevel > 0 Then sLevelSpace = Space$(iLevel * 3) Else
sLevelSpace = ""
sOut = sOut & vbCrLf & sLevelSpace & Mid$(sXML, iOpenPos,
iClosePos - iOpenPos + 1) & vbCrLf
Else
sOut = sOut & sLevelSpace & Mid$(sXML, iOpenPos, iClosePos -
iOpenPos + 1) & vbCrLf
iLevel = iLevel + 1
If iLevel > 0 Then sLevelSpace = Space$(iLevel * 3) Else
sLevelSpace = ""
End If
iLastPos = iClosePos + 1
iOpenPos = InStr(iLastPos, sXML, "<")
If iOpenPos > iLastPos Then
sOut = sOut & sLevelSpace & Mid$(sXML, iLastPos, iOpenPos -
iLastPos)
End If
End If
Loop While iOpenPos > 0
End If
If iLastPos > 0 And iLastPos < Len(sXML) Then
sOut = sOut & Mid$(sXML, iLastPos)
End If
NiceXML = sOut
End Function
Private Sub cboAddresses_Click()
If cboAddresses.ListIndex > -1 Then
With m_oPerson.Addresses(cboAddresses.ListIndex + 1)
txtAddress1 = .AddressLine1
txtAddress2 = .AddressLine2
txtState = .State
txtCity = .City
txtZipCode = .ZipCode
End With
Else
txtAddress1 = ""
txtAddress2 = ""
txtState = ""
txtCity = ""
txtZipCode = ""
End If
End Sub
Private Sub cmdClear_Click()
Set m_oPerson = New Person
ShowPerson
End Sub
Private Sub cmdFromXML_Click()
Dim oPropertyBag As New XMLPropertyBag
oPropertyBag.Contents = txtXML.Text
oPropertyBag.RestoreState m_oPerson, "Person1"
ShowPerson
End Sub
Private Sub cmdToXML_Click()
Dim oPropertyBag As New XMLPropertyBag
' Demonstrates how we can save multiple objects
' to the same property bag using the Name property
' to uniquely identify the item:
oPropertyBag.SaveState m_oPerson, "Person1"
oPropertyBag.SaveState m_oPerson, "Person2"
Debug.Print NiceXML(oPropertyBag.Contents)
' You can replace existing object values:
oPropertyBag.SaveState m_oPerson, "Person1"
Debug.Print NiceXML(oPropertyBag.Contents)
' You can delete objects completely:
oPropertyBag.DeleteObject "Person", "Person2"
txtXML.Text = NiceXML(oPropertyBag.Contents)
End Sub
Private Sub Form_Load()
' Set up the class states:
m_oPerson.FirstName = "Billy"
m_oPerson.LastName = "Bob"
m_oPerson.Birthday = "09/09/1969"
With m_oPerson.Addresses.Add
.AddressLine1 = "123 Main Street"
.AddressLine2 = "Suite 456"
.City = "Austin"
.State = "TX"
.ZipCode = "78799"
End With
With m_oPerson.Addresses.Add
.AddressLine1 = "22A Mount Pleasant St"
.City = "Liverpool"
.State = "N/A"
.ZipCode = "L25 9RQ"
End With
ShowPerson
End Sub
