UTILISATION DES PROPERTYBAG: FICHIER DE CONFIGURATION

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Config"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private colPName As Collection
Private colPValue As Collection

Private Sub Class_Initialize()
  Set colPName = New Collection
  Set colPValue = New Collection
End Sub

Private Sub Class_Terminate()
  Set colPName = Nothing
  Set colPValue = Nothing
End Sub

Public Property Get PropertyValue(ByVal PropertyName As String) As Variant
Dim I As Integer

  I = PropertyIndex(PropertyName)
  If I > 0 Then
    PropertyValue = colPValue(I)
  Else
    PropertyValue = Null
  End If
End Property

Public Property Let PropertyValue(ByVal PropertyName As String, ByVal NewValue As Variant)
Dim I As Integer

  I = PropertyIndex(PropertyName)
  If I > 0 Then
    If IsNull(NewValue) = True Then
      colPName.Remove I
      colPValue.Remove I
    Else
      colPName.Add LCase$(Trim$(PropertyName))
      colPValue.Add NewValue
    End If
  Else
    If IsNull(NewValue) = False Then
      colPName.Add LCase$(Trim$(PropertyName))
      colPValue.Add NewValue
    End If
  End If
End Property

Public Function SaveFile(ByVal FileName As String) As Boolean
Dim PB As PropertyBag
Dim I As Integer

  If Len(FileName) > 0 Then
    Set PB = New PropertyBag
    PB.WriteProperty "PropertyCount", colPName.Count
    For I = 1 To colPName.Count
      PB.WriteProperty "PropertyName" & I, colPName(I)
      PB.WriteProperty "PropertyValue" & I, colPValue(I)
    Next
    On Error Resume Next
    Kill FileName
    On Error GoTo 0
    Open FileName For Binary As #1
    Put #1, , PB.Contents
    Close #1
  End If
  SaveFile = True
End Function

Public Function LoadFile(ByVal FileName As String) As Boolean
Dim PB As PropertyBag
Dim I As Integer
'Dim NbDtl As Integer
Dim vPB As Variant
Dim bPB() As Byte
'Dim VD As CVerDetail
'Dim Pwd As String

  ClearCollection colPName
  ClearCollection colPValue

  If Len(FileName) > 0 Then
    On Error GoTo ErrorOpen
    Open FileName For Binary As #1
    Get #1, , vPB
    bPB = vPB
    Close #1
    Set PB = New PropertyBag
    PB.Contents = bPB
    
    For I = 1 To PB.ReadProperty("PropertyCount", 0)
      colPName.Add PB.ReadProperty("PropertyName" & I, "")
      colPValue.Add PB.ReadProperty("PropertyValue" & I, Null)
    Next
    LoadFile = True
  Else
    LoadFile = False
  End If
  Exit Function

ErrorOpen:
  Close 1
  LoadFile = False
  Exit Function
End Function

Private Function PropertyExists(ByVal PropertyName As String) As Boolean
  If PropertyIndex(PropertyName) > 0 Then PropertyExists = True
End Function

Private Function PropertyIndex(ByVal PropertyName As String) As Integer
Dim I As Integer

  PropertyName = LCase$(Trim$(PropertyName))
  For I = 1 To colPName.Count
    If colPName(I) = PropertyName Then PropertyIndex = I: Exit Function
  Next
End Function

Private Sub ClearCollection(ByRef Col As Collection)
  While Col.Count > 0
    Col.Remove 1
  Wend
End Sub