Home

Comments

If you use the PropertyBag Object then you'll know how indispensable it is. It does have some drawbacks though (primarily the lack of persistence for private object modules). My PropertyBag Class goes a long way towards fixing those drawbacks. I’ve added the ability to persist private object modules, to output to file (binary) or string (base64 encoded), to optionally compress the output using the zlib library, and I’ve managed to keep it compatible with the Microsoft’s PropertyBag!

I must give mention to Francesco Balena (see the links at the bottom of the page) whose article on the PropertyBag inspired me.

What it can do

Retains compatibility with Visual Basic's built-in PropertyBag
Persist Private Class Modules using the IPropertyBagClass Interface
Save/Load the PropertyBagClass contents to file or string
Optionally compress the PropertyBagClass Contents using the ZLib dll

Reference

PropertyBagClass Properties

Contents [= NewContents]

Read-Write

Return Type is a Variant

Name	Type	Description

NewContents	Variant

ZLibVersion

Read-Only

Return Type is a String

PropertyBagClass Methods

LoadFromString Data

Name	Type	Description

Data	String

SaveToString ([Compress])

Return Type is a String Value

Name	Type	Description

Compress	Boolean	Optional

LoadFromFile (Path)

Return Type is a Boolean Value

Name	Type	Description

Path	String

SaveToFile (Path[, Compress][, OverWrite])

Return Type is a Boolean Value

Name	Type	Description

Path	String
Compress	Boolean	Optional
OverWrite	Boolean	Optional

WriteProperty Name, Value[, DefaultValue]

Name	Type	Description

Name	String
Value	Variant
DefaultValue	Variant	Optional

ReadProperty (Name[, DefaultValue])

Return Type is a Variant Value

Name	Type	Description

Name	String
DefaultValue	Variant	Optional

IPropertyBagClass Methods

WriteProperties PropBag

Name	Type	Description

PropBag	PropertyBagClass

ReadProperties PropBag

Name	Type	Description

PropBag	PropertyBagClass

Usage

Add PropertyBagClass.cls and IPropertyBagClass.cls to your Project

'To persist a Private Object you need to Implement the IPropertyBag Class
'MyGameClass Object
Option Explicit

Implements IPropertyBagClass

Public Name As String
Public Score As Long
Public HitPoints As Long
Public Lives As Long

Public PosX As Long
Public PosY As Long

Private Sub IPropertyBagClass_ReadProperties(PropBag As PropertyBagClass)

   Name = PropBag.ReadProperty("Name", "")
   Score = PropBag.ReadProperty("Score", 0)
   HitPoints = PropBag.ReadProperty("HitPoints", 0)
   Lives = PropBag.ReadProperty("Lives", 0)

   PosX = PropBag.ReadProperty("PosX", 0)
   PosY = PropBag.ReadProperty("PosY", 0)

End Sub

Private Sub IPropertyBagClass_WriteProperties(PropBag As PropertyBagClass)

   PropBag.WriteProperty "Name", Name
   PropBag.WriteProperty "Score", Score
   PropBag.WriteProperty "HitPoints", HitPoints
   PropBag.WriteProperty "Lives", Lives

   PropBag.WriteProperty "PosX", PosX
   PropBag.WriteProperty "PosY", PosY

End Sub

'And to save it...

   Dim mg As MyGameClass
   Dim pb As PropertyBagClass

   Set pb = New PropertyBagClass
   pb.WriteProperty "MyGame", MyGame
   If Not pb.SaveToFile(Path, False, True) Then
      MsgBox "Couldn't save the file " & Path, vbExclamation
   End If
   Set pb = Nothing

'And to reload it...

   Dim mg As MyGameClass
   Dim pb As PropertyBagClass

   Set pb = New PropertyBagClass
   If pb.LoadFromFile(Path) Then
      Set mg = New MyGameClass
      'Note: When reading a private object you have to create an instance
      'of it first and pass it as the default parameter
      Set mg = pb.ReadProperty("MyGame", mg)
      Set MyGame = mg
      Set mg = Nothing
   Else
      MsgBox "Couldn't load the file " & Path, vbExclamation
   End If
   Set pb = Nothing

The Code

PropertyBagClass.cls

Option Explicit

Private Const PropertyBag_Header As Long = &H12F724

Private Type tHeader
   Signature As Long
   OrigionalSize As Long
   CompressedSize As Long
   CRC32 As Long
End Type

Private pb As PropertyBag

Private Const Equals As Byte = 61    'Asc("=")

Private Const Mask1 As Byte = 3      '00000011
Private Const Mask2 As Byte = 15     '00001111
Private Const Mask3 As Byte = 63     '00111111
Private Const Mask4 As Byte = 192    '11000000
Private Const Mask5 As Byte = 240    '11110000
Private Const Mask6 As Byte = 252    '11111100

Private Const Shift2 As Byte = 4
Private Const Shift4 As Byte = 16
Private Const Shift6 As Byte = 64

Private Const Base64Lookup As String = _
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As _
Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal _
lpBuffer As String, ByVal lpString As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal _
lpString As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias _
"GetFileAttributesA" (ByVal lpFileName As String) As Long

Private Declare Function ZLibVer Lib "zlib" Alias "zlibVersion" () As Long
Private Declare Function Compress Lib "zlib" Alias "compress" (Dest As Any, _
destLen As Any, Src As Any, ByVal srcLen As Long) As Long
Private Declare Function UnCompress Lib "zlib" Alias "uncompress" (Dest As Any, _
destLen As Any, Src As Any, ByVal srcLen As Long) As Long
Private Declare Function CRC32 Lib "zlib" Alias "crc32" (ByVal crc As Long, _
Buffer As Any, ByVal Length As Long) As Long

Private Function PointerToString(Pointer As Long) As String

   Dim l As Long
   Dim s As String

   l = lstrlen(Pointer)
   s = Space(l)
   l = lstrcpy(s, Pointer)
   If l > 0 Then
      PointerToString = s
   End If

End Function

Public Property Get ZLibVersion() As String

   On Error GoTo eh

   ZLibVersion = PointerToString(ZLibVer)

eh:
End Property

Private Function FileExists(FilePath As String) As Boolean

   FileExists = GetFileAttributes(FilePath) <> -1

End Function

Private Function RemoveFile(Path As String) As Boolean

   On Error GoTo eh

   Kill Path
   RemoveFile = True

eh:
End Function

Public Property Get Contents() As Variant

   Contents = pb.Contents

End Property

Public Property Let Contents(NewContents As Variant)

   pb.Contents = NewContents

End Property

Public Function ReadProperty(Name As String, Optional DefaultValue As Variant) _
As Variant

   Dim p As PropertyBagClass
   Dim i As IPropertyBagClass

   If TypeOf DefaultValue Is IPropertyBagClass Then
      Set p = New PropertyBagClass
      p.Contents = pb.ReadProperty(Name, DefaultValue)

      Set i = DefaultValue
      i.ReadProperties p
      Set i = Nothing
      Set p = Nothing

      Set ReadProperty = DefaultValue
   Else
      ReadProperty = pb.ReadProperty(Name, DefaultValue)
   End If

End Function

Public Sub WriteProperty(Name As String, Value As Variant, Optional _
DefaultValue As Variant)

   Dim p As PropertyBagClass
   Dim i As IPropertyBagClass

   If TypeOf Value Is IPropertyBagClass Then
      Set p = New PropertyBagClass

      Set i = Value
      i.WriteProperties p
      Set i = Nothing

      pb.WriteProperty Name, p.Contents
      Set p = Nothing
   Else
      pb.WriteProperty Name, Value, DefaultValue
   End If

End Sub

Private Sub Class_Initialize()

   Set pb = New PropertyBag

End Sub

Private Sub Class_Terminate()

   Set pb = Nothing

End Sub

Public Function SaveToFile(Path As String, Optional Compress As Boolean, _
Optional OverWrite As Boolean) As Boolean

   Dim fh As Long
   Dim b() As Byte

   If Compress Then
      If Len(ZLibVersion) = 0 Then
         Exit Function
      End If
   End If

   If FileExists(Path) Then
      If OverWrite Then
         If Not RemoveFile(Path) Then
            Exit Function
         End If
      Else
         Exit Function
      End If
   End If

   b = pb.Contents
   If Compress Then
      b = CompressBytes(b)
   End If

   fh = FreeFile
   Open Path For Binary As #fh
   Put #fh, , b
   Close #fh

   SaveToFile = True

End Function

Public Function LoadFromFile(Path As String) As Boolean

   Dim fh As Long
   Dim b() As Byte

   If Not FileExists(Path) Then
      Exit Function
   End If

   fh = FreeFile
   Open Path For Binary As #fh
   ReDim b(LOF(fh) - 1)
   Get #fh, , b
   Close #fh

   pb.Contents = UnCompressBytes(b)

   LoadFromFile = True

End Function

Public Function SaveToString(Optional Compress As Boolean) As String

   Dim b() As Byte

   If Compress Then
      If Len(ZLibVersion) = 0 Then
         Exit Function
      End If
   End If

   b = pb.Contents
   If Compress Then
      b = CompressBytes(b)
   End If
   SaveToString = Base64Encode(b)

End Function

Public Sub LoadFromString(Data As String)

   pb.Contents = UnCompressBytes(Base64DeCode(Data))

End Sub

Private Function Base64Encode(Data() As Byte) As String

   Dim EncodedData() As Byte

   Dim FileLength As Long
   Dim EncodedLength As Long

   Dim l As Long
   Dim m As Long

   Dim Index As Long

   Dim CharCount As Long

   If Not IsDimensioned(Data) Then
      Exit Function
   End If

   FileLength = UBound(Data) + 1

   EncodedLength = (FileLength \ 3) * 4
   If FileLength Mod 3 > 0 Then EncodedLength = EncodedLength + 4
   EncodedLength = EncodedLength + ((EncodedLength \ 76) * 2)
   If EncodedLength Mod 78 = 0 Then EncodedLength = EncodedLength - 2
   ReDim EncodedData(EncodedLength - 1)

   m = (FileLength) Mod 3

   For l = 0 To UBound(Data) - m Step 3
      EncodedData(Index) = EnCodeByte((Data(l) \ Shift2))
      EncodedData(Index + 1) = EnCodeByte(((Data(l) And Mask1) * Shift4) _
      + ((Data(l + 1)) \ Shift4))
      EncodedData(Index + 2) = EnCodeByte(((Data(l + 1) And Mask2) * Shift2) _
      + (Data(l + 2) \ Shift6))
      EncodedData(Index + 3) = EnCodeByte(Data(l + 2) And Mask3)
      Index = Index + 4
      CharCount = CharCount + 4

      If CharCount = 76 And Index < EncodedLength Then
         EncodedData(Index) = 13
         EncodedData(Index + 1) = 10
         CharCount = 0
         Index = Index + 2
      End If
   Next

   If m = 1 Then
      EncodedData(Index) = EnCodeByte((Data(l) \ Shift2))
      EncodedData(Index + 1) = EnCodeByte((Data(l) And Mask1) * Shift4)
      EncodedData(Index + 2) = Equals
      EncodedData(Index + 3) = Equals
      Index = Index + 4
   ElseIf m = 2 Then
      EncodedData(Index) = EnCodeByte((Data(l) \ Shift2))
      EncodedData(Index + 1) = EnCodeByte(((Data(l) And Mask1) * Shift4) _
      + ((Data(l + 1)) \ Shift4))
      EncodedData(Index + 2) = EnCodeByte((Data(l + 1) And Mask2) * Shift2)
      EncodedData(Index + 3) = Equals
      Index = Index + 4
   End If

   Erase Data
   Base64Encode = StrConv(EncodedData, vbUnicode)
   Erase EncodedData

End Function

Private Function Base64DeCode(EncodedString As String) As Byte()

   Dim Data() As Byte
   Dim EncodedData() As Byte

   Dim FileLength As Long
   Dim EncodedLength As Long

   Dim l As Long
   Dim m As Long

   Dim Index As Long

   Dim CharCount As Long

   If Len(EncodedString) = 0 Then
      Exit Function
   End If

   EncodedString = Replace(EncodedString, vbCrLf, "")
   EncodedString = Replace(EncodedString, "=", "")

   EncodedData = StrConv(EncodedString, vbFromUnicode)

   For l = 0 To UBound(EncodedData)
      EncodedData(l) = DeCodeByte(EncodedData(l))
   Next

   EncodedLength = UBound(EncodedData) + 1

   FileLength = (EncodedLength \ 4) * 3

   m = EncodedLength Mod 4
   If m = 2 Then
      FileLength = FileLength + 1
   ElseIf m = 3 Then
      FileLength = FileLength + 2
   End If

   ReDim Data(FileLength - 1)

   For l = 0 To UBound(EncodedData) - m Step 4
      Data(Index) = (EncodedData(l) * Shift2) + (EncodedData(l + 1) \ Shift4)
      Data(Index + 1) = ((EncodedData(l + 1) And Mask2) * Shift4) _
      + (EncodedData(l + 2) \ Shift2)
      Data(Index + 2) = ((EncodedData(l + 2) And Mask1) * Shift6) _
      + EncodedData(l + 3)
      Index = Index + 3
   Next

   Select Case ((UBound(EncodedData) + 1) Mod 4)
   Case 2
      Data(Index) = (EncodedData(l) * Shift2) + (EncodedData(l + 1) \ Shift4)
   Case 3
      Data(Index) = (EncodedData(l) * Shift2) + (EncodedData(l + 1) \ Shift4)
      Data(Index + 1) = ((EncodedData(l + 1) And Mask2) * Shift4) _
      + (EncodedData(l + 2) \ Shift2)
   End Select

   Erase EncodedData
   Base64DeCode = Data
   Erase Data

End Function

Private Function EnCodeByte(Code As Byte) As Byte

   EnCodeByte = Asc(Mid$(Base64Lookup, Code + 1, 1))

End Function

Private Function DeCodeByte(Code As Byte) As Byte

   Dim s As String
   Dim l As Long

   s = Chr$(Code)
   l = InStr(1, Base64Lookup, s)
   If l > 0 Then
      DeCodeByte = l - 1
   End If

End Function

Private Function IsDimensioned(v As Variant) As Boolean

   Dim l As Long

   On Error GoTo eh

   If IsArray(v) Then
      l = UBound(v)
      IsDimensioned = True
   End If

eh:
End Function

Private Function CompressBytes(b() As Byte) As Byte()

   Dim Header As tHeader
   Dim Buffer() As Byte
   Dim BufferSize As Long
   Dim r As Long

   If Not IsDimensioned(b) Then
      Exit Function
   End If

   Header.Signature = PropertyBag_Header
   Header.OrigionalSize = UBound(b) + 1
   Header.CRC32 = CRC32(0&, b(0), Header.OrigionalSize)

   BufferSize = (Header.OrigionalSize * 1.01) + 12 + Len(Header)
   ReDim Buffer(BufferSize) As Byte

   r = Compress(Buffer(Len(Header)), BufferSize, b(0), Header.OrigionalSize)
   If r = 0 Then
      Header.CompressedSize = BufferSize
      CopyMemory Buffer(0), Header, Len(Header)

      ReDim Preserve Buffer(Len(Header) + BufferSize)
      CompressBytes = Buffer
   End If

End Function

Private Function UnCompressBytes(b() As Byte) As Byte()

   Dim Header As tHeader
   Dim Buffer() As Byte
   Dim BufferSize As Long
   Dim r As Long

   If Not IsDimensioned(b) Then
      Exit Function
   End If

   If UBound(b) < Len(Header) Then
      UnCompressBytes = b
      Exit Function
   End If

   CopyMemory Header, b(0), Len(Header)
   If Header.Signature <> PropertyBag_Header Then
      UnCompressBytes = b
      Exit Function
   End If

   BufferSize = (Header.OrigionalSize * 1.01) + 12

   ReDim Buffer(BufferSize) As Byte

   r = UnCompress(Buffer(0), BufferSize, b(Len(Header)), Header.CompressedSize)
   If r = 0 Then
      ReDim Preserve Buffer(BufferSize)
      If CRC32(0&, Buffer(0), Header.OrigionalSize) = Header.CRC32 Then
         UnCompressBytes = Buffer
      End If
   End If

End Function

IPropertyBagClass.cls

Option Explicit

Public Sub ReadProperties(PropBag As PropertyBagClass)

End Sub

Public Sub WriteProperties(PropBag As PropertyBagClass)

End Sub

Downloads

PropertyBagClass.zip - contains: PropertyBagClass.cls, IPropertyBagClass.cls, zlib.dll (29.5 kb)

MyGame.zip - A simple project to demonstarte how to persist private objects (27.4 kb)

Links

A very good Article on DevX about extending the PropertyBag by Francesco Balena

Another good article on vbaccelerator about persisting objects/data to XML by Steve McMahon

Unless otherwise stated, the code on this site is Copyright to Andrew McMillan. You may use this code in your projects (both commercial and non-commercial) but you are not permitted to republish this code in any form without the Author's prior consent.

The code on this site is supplied "as is" and no claims are made as to its soundness. The Author claims no responsibility for or liability from use of said source code.