CPropBag.cls

Option Explicit

' CPropBag.cls
'
' simple class to store/retrieve settings and persist
' them using a standard propertybag object, the class
' allows to store variables of any type, including the
' objects (e.g StdFont, classes and so on); the class
' also implements simple encryption to allow encrypting
' the data saved to disk and decrypting them upon load
'

' private workareas
Private msFileName    As String
Private mbAutoSave    As Boolean
Private mbEncrypt     As Boolean
Private mlSeed        As Long
Private mobjPB        As PropertyBag
Private mlErrNum      As Long
Private msErrMsg      As String


' instance
Private Sub Class_Initialize()
  Dim sTemp, nPos

  ' set a reasonable default
  ' for the storage file name
  sTemp = App.EXEName
  nPos = InStrRev(sTemp, ".")
  If nPos > 0 Then
    sTemp = Mid(sTemp, 1, nPos - 1)
  End If
  msFileName = App.Path & "\" & sTemp & ".cfg"

  ' initialize the PB
  Set mobjPB = New PropertyBag

  ' set defaults
  mbAutoSave = False
  mbEncrypt = False
  mlSeed = 0

  ' reset error infos
  SetError 0, ""
End Sub

' destroy
Private Sub Class_Terminate()
  Set mobjPB = Nothing
End Sub

' set persist file pathname
Public Property Let FileName(ByVal sPathName As String)
  msFileName = sPathName
End Property

' get persist file pathname
Public Property Get FileName() As String
  FileName = msFileName
End Property

' set autosave flag
Public Property Let AutoSave(ByVal bYesNo As Boolean)
  mbAutoSave = bYesNo
End Property

' get autosave flag
Public Property Get AutoSave() As Boolean
  AutoSave = mbAutoSave
End Property

' set encrypt/decrypt password
Public Property Let Password(ByVal sPwd As String)
  If Len(sPwd) < 1 Then
    ' disable encryption
    mbEncrypt = False
    mlSeed = 0
    Exit Property
  End If
  ' calculate the seed and enable encryption
  mlSeed = CalcSeed(sPwd)
  mbEncrypt = True
End Property

' get the propertybag object
Public Property Get PropBag() As PropertyBag
  Set PropBag = mobjPB
End Property

' get the last error number
Public Property Get ErrNum() As Long
  ErrNum = mlErrNum
End Property

' get the last error message
Public Property Get ErrMsg() As Long
  ErrMsg = msErrMsg
End Property

' stores a value
Public Sub PutValue(ByVal sKeyName As String, ByVal vData As Variant)
  mobjPB.WriteProperty sKeyName, vData
  If mbAutoSave = True Then
    SaveSettings
  End If
End Sub

' retrieves a value, if not present, returns the default
Public Function GetValue(ByVal sKeyName As String, _
                         ByVal vDefault As Variant) As Variant
  Dim vValue As Variant

  vValue = mobjPB.ReadProperty(sKeyName, vDefault)
  If IsObject(vValue) Or IsObject(vDefault) Then
    Set GetValue = vValue
  Else
    GetValue = vValue
  End If
End Function

' Saves the PB to disk
Public Function SaveSettings() As Boolean
  Dim fp As Long
  Dim cbContents() As Byte
  Dim bRet As Boolean

  On Local Error GoTo Catch
  SetError 0, ""
  bRet = False
  SaveSettings = bRet
  If Len(msFileName) < 1 Then
    SetError vbObjectError, "Missing storage file name"
    Exit Function
  End If

  ' get the PB contents and saves it to binary file
  cbContents = mobjPB.Contents
  If mbEncrypt Then
    ' encrypt the data
    EncDec cbContents
  End If
  fp = FreeFile()
  Open msFileName For Binary Access Write As #fp
  Put #fp, , cbContents
  Close #fp
  bRet = True

BailOut:
  ' common exit point
  On Local Error Resume Next
  Close #fp
  SaveSettings = bRet
  Exit Function

Catch:
  ' error handler
  SetError Err.Number, Err.Description
  bRet = False
  Resume BailOut
End Function

' Loads the PB from disk
Public Function LoadSettings() As Boolean
  Dim fp As Long
  Dim cbContents() As Byte
  Dim bRet As Boolean

  On Local Error GoTo Catch
  SetError 0, ""
  bRet = False
  LoadSettings = bRet
  If Len(msFileName) < 1 Then
    SetError vbObjectError, "Missing storage file name"
    Exit Function
  End If

  ' loads PB data from binary file
  fp = FreeFile()
  Open msFileName For Binary Access Read As #fp
  ReDim cbContents(LOF(fp) - 1)
  Get #fp, , cbContents
  Close #fp
  If mbEncrypt Then
    ' decrypt the data
    EncDec cbContents
  End If
  mobjPB.Contents = cbContents
  bRet = True

BailOut:
  ' common exit point
  On Local Error Resume Next
  Close #fp
  LoadSettings = bRet
  Exit Function

Catch:
  ' error handler
  SetError Err.Number, Err.Description
  bRet = False
  Resume BailOut
End Function

' encrypt/decrypt a byte array
Private Sub EncDec(ByRef cbContents() As Byte)
  Dim lIdx As Long

  ' initialize the random generator
  InitRNG

  ' loop over the array and encrypt/decrypt bytes
  ' using a random numbers sequence depending from
  ' the given password
  For lIdx = LBound(cbContents) To UBound(cbContents)
    cbContents(lIdx) = cbContents(lIdx) Xor RndByte()
  Next lIdx

  ' reset the random generator
  Randomize Timer
End Sub

' initialize the random generator
Private Sub InitRNG()
  Call Rnd(-1) ' <-- see randomize help
  Randomize mlSeed
End Sub

' get a random byte value
Private Function RndByte() As Byte
  RndByte = Int(256 * Rnd)
End Function

' calculate the seed for a password
Private Function CalcSeed(ByVal sPwd As String) As Long
  Dim cbPass() As Byte
  Dim lHash As Long
  Dim lIdx As Long

  On Local Error Resume Next
  lHash = 0
  cbPass = StrConv(sPwd, vbFromUnicode)
  For lIdx = LBound(cbPass) To UBound(cbPass)
    lHash = lHash + (lIdx * cbPass(lIdx))
  Next lIdx
  CalcSeed = lHash
End Function

' set last error informations
Private Sub SetError(ByVal lNum As Long, _
                     ByVal sMsg As String)

  mlErrNum = lNum
  msErrMsg = sMsg
End Sub