Imports System.IO
Imports System.Runtime.Serialization
Imports System.Runtime.Serialization.Formatters.Binary
Public Class UserPreferences
#Region "Protected Members"
Protected Shared m_AutoSave As Boolean
Protected Shared m_Preferences As Hashtable
' Code page 1252 preserves ascii through 255.
Protected Shared ReadOnly CodePage1252 As System.Text.Encoding = System.Text.Encoding.GetEncoding(1252)
#End Region
#Region "Nested Classes/Structures"
' STRUCTURE PersistData is only used to de/serialize
' the information to a stream (in this case, a binary file).
<Serializable()> Public Structure PersistData
Public Key As String
Public Value As String
End Structure
' CLASS SettingData allows changes to its values.
' This is how the data is cached/manipulated at runtime.
Protected Class SettingData
Public Sub New()
MyBase.new()
End Sub
Public Sub New(ByVal Data As PersistData)
MyBase.new()
Me.Key = Data.Key
m_Value = Data.Value
IsDirty = False
Persist = True
End Sub
Public Sub New(ByVal Key As String, ByVal Value As String)
MyBase.new()
Me.Key = Key
m_Value = Value
IsDirty = True
Persist = False
End Sub
Public ID As Integer ' used with db: record id
Public Group As String ' used with db: Group = UserID
Public Key As String
Public Persist As Boolean
Public IsDirty As Boolean
Public Property Value() As String
Get
Return m_Value
End Get
Set(ByVal Value As String)
If m_Value <> Value Then
IsDirty = True
m_Value = Value
End If
End Set
End Property
Private m_Value As String
Public Function GetData() As PersistData
Dim pd As New PersistData()
pd.Key = Me.Key
pd.Value = Me.Value
Return pd
End Function
Public Overloads Function GetHashCode() As Integer
Return HashCode(Key)
End Function
Public Shared Function HashCode(ByVal Key As String) As Integer
' use the key for lookups
Return UCase(Key).GetHashCode
End Function
End Class
#End Region
' AutoSave = True means new or changed preferences (Persist=True)
' are saved immediately (such as saving to a database or registry,
' where atomic updates are possible); False means you must
' explicitly call SavePreferences (such as with file storage,
' where atomic updates are not (easily) done.)
Public Shared Property AutoSave() As Boolean
Get
Return m_AutoSave
End Get
Set(ByVal Value As Boolean)
m_AutoSave = Value
End Set
End Property
' GetPreference: returns DefaultValue if not found, or on certain errors.
' USE THE SAME TYPE for SavePreference() AND DefaultValue! The type of
' the DefaultValue determines HOW the value is restored.
Public Shared Function GetPreference(ByVal Key As String, ByVal DefaultValue As Object) As Object
InitCache()
If m_Preferences.ContainsKey(SettingData.HashCode(Key)) Then
Dim data As SettingData
data = CType(m_Preferences.Item(SettingData.HashCode(Key)), SettingData)
Dim v As String = data.Value
If v Is Nothing Then
' not a value; return default
Return DefaultValue
End If
If TypeOf DefaultValue Is DateTime Then
' DateTimes are stored by (long) Tick count.
Return New DateTime(Long.Parse(v))
ElseIf TypeOf DefaultValue Is IConvertible Then
If DefaultValue.GetType.IsEnum Then
' handle enum separately
Return System.Enum.Parse(DefaultValue.GetType, v)
Else
' all other convertable (primative) types
Return System.Convert.ChangeType(v, DefaultValue.GetType)
End If
ElseIf TypeOf DefaultValue Is ISerializable OrElse _
TypeOf DefaultValue Is System.ValueType OrElse _
IsArray(DefaultValue) OrElse DefaultValue Is Nothing _
OrElse DefaultValue.GetType.IsSerializable Then
' Serializable object, structures, and arrays handled here.
' Also assume Nothing resolves to a serialized "thing".
' Restore value from stream:
Dim bformatter As New BinaryFormatter()
Dim b As Byte() = CodePage1252.GetBytes(v)
Dim stream As New MemoryStream(b)
Try
Return bformatter.Deserialize(stream)
Catch ex As Exception
' Can't deserialize to target type.
' Probably because typedef has been changed.
' I could throw an error here, but I'd rather just
' ignore the saved data and continue.
Return DefaultValue
End Try
Else
' Here the developer is requesting data that CAN'T
' be serialized or deserialized. That's a coding problem!
Throw New ArgumentException("Unable to restore value of type '" & TypeName(DefaultValue) & "'.")
End If
Else ' not saved, return default
Return DefaultValue
End If
End Function
' SavePreference: updates or adds key/value to internal cache.
' If Persist = True and AutoSave is enabled, the value will
' also be inserted/updated in the persistance store.
' Use Value = Nothing to delete a preference.
Public Shared Sub SavePreference(ByVal Key As String, ByVal Value As Object, ByVal Persist As Boolean)
InitCache()
Dim newValue As String
Dim KeyHash As Integer = SettingData.HashCode(Key)
Dim data As SettingData
If Value Is Nothing Then ' this is a DELETE
' remove from local cache
If m_Preferences.ContainsKey(KeyHash) Then
data = CType(m_Preferences.Item(KeyHash), SettingData)
m_Preferences.Remove(KeyHash)
If Persist AndAlso AutoSave Then
' delete from persistance store
DeleteDataItem(data)
End If
End If
Exit Sub
ElseIf TypeOf Value Is DateTime Then
' use ticks; convert only returns seconds.
newValue = CType(Value, DateTime).Ticks.ToString
ElseIf TypeOf Value Is IConvertible Then
' convert primative or enum to string representation.
newValue = CType(System.Convert.ChangeType(Value, TypeCode.String), String)
ElseIf TypeOf Value Is ISerializable OrElse _
TypeOf Value Is System.ValueType OrElse IsArray(Value) _
OrElse Value.GetType.IsSerializable Then
' Serializable object, structure, or array
' serialize object's data into string
Dim stream As MemoryStream = New MemoryStream()
Dim bformatter As New BinaryFormatter()
Try
bformatter.Serialize(stream, Value)
newValue = CodePage1252.GetString(stream.GetBuffer())
Catch ex As Exception
' probably an array of unsupported (not serializable) objects.
Throw New ArgumentException("Unable to serialize value of type '" & TypeName(Value) & "'.")
End Try
Else
' Can't serialize: programmer error!
Throw New ArgumentException("Unable to save value of type '" & TypeName(Value) & "'.")
End If
' Update cache with current value
If m_Preferences.ContainsKey(KeyHash) Then
data = CType(m_Preferences.Item(KeyHash), SettingData)
If data.Value = newValue Then Exit Sub
data.Value = newValue
If Persist AndAlso AutoSave Then
UpdateDataItem(data)
End If
Else
data = New SettingData(Key, newValue)
data.Persist = Persist
m_Preferences.Add(KeyHash, data)
If Persist AndAlso AutoSave Then
SaveNewDataItem(data)
End If
End If
End Sub
' load data, if necessary
Private Shared Sub InitCache()
If m_Preferences Is Nothing Then FetchPreferences()
End Sub
' Returns default file name:
' x:\Documents and Settings\<username>\Application Data\<exename>\Preferences.dat
Public Shared Function DefaultFileName() As String
Dim fn As String = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData)
fn &= "\" & Application.ProductName & "\Preferences.dat"
Return fn
End Function
' Load preferences from file. If filename not provided,
' the default filename is used.
Public Shared Sub FetchPreferences(Optional ByVal FileName As String = "")
' load from user file...
If FileName = "" Then FileName = DefaultFileName()
m_Preferences = New Hashtable()
If File.Exists(FileName) Then
Dim persist As PersistData()
Dim bformatter As New BinaryFormatter()
Dim stream As IO.FileStream
Try
stream = File.OpenRead(FileName)
Catch ex As Exception
Throw New Exception("Unable to read from file: " & ex.Message, ex)
End Try
Try
' deserialize the whole she-bang
persist = CType(bformatter.Deserialize(stream), PersistData())
Catch ex As Exception
Throw New Exception("Unable to deserialize: " & ex.Message, ex)
End Try
Try
stream.Close()
Catch
End Try
Dim i As Integer, setting As SettingData
' now loop through, creating a SettingData obj
' for each key/value in the array.
For i = 0 To persist.Length - 1
setting = New SettingData(persist(i))
m_Preferences.Add(setting.GetHashCode, setting)
Next
End If
End Sub
' Save preferences to file. If filename not provided,
' the default filename is used.
Public Shared Sub SavePreferences(Optional ByVal FileName As String = "")
If Not m_Preferences Is Nothing Then
' save to user file...
If FileName = "" Then FileName = DefaultFileName()
Dim de As DictionaryEntry, setting As SettingData
Dim persist As PersistData(), pindex As Integer = 0
' Create array to hold key/values:
' init capacity to total items
ReDim persist(m_Preferences.Count)
' get all persistable settings from cache:
For Each de In m_Preferences
setting = CType(de.Value, SettingData)
If setting.Persist Then ' if saving to db, you would
' also want to look at IsDirty.
' add data to array
persist(pindex) = setting.GetData()
pindex += 1
End If
Next
' remove existing file
If File.Exists(FileName) Then
Try
File.Delete(FileName)
Catch ex As Exception
Throw New Exception("Unable to remove file: " & FileName & vbCrLf & ex.Message, ex)
Exit Sub
End Try
End If
If pindex = 0 Then
' nothing to save! File is deleted, so we're done!
Exit Sub
End If
' shrink array to persistable count:
ReDim Preserve persist(pindex - 1)
' Open target file:
Dim stream As IO.FileStream
Dim fi As New FileInfo(FileName)
Try
' ensure path exists:
If Not Directory.Exists(fi.Directory.FullName) Then
Directory.CreateDirectory(fi.Directory.FullName)
End If
stream = File.Create(FileName)
Catch ex As Exception
Throw New Exception("Unable to create file: " & FileName & vbCrLf & ex.Message, ex)
Exit Sub
End Try
Dim bformatter As New BinaryFormatter()
' serialize whole array to file:
Try
bformatter.Serialize(stream, persist)
Catch ex As Exception
Throw New Exception("Serialization failed: " & ex.Message, ex)
Exit Sub
End Try
Try
stream.Close()
Catch
End Try
End If
End Sub
#Region "Atomic Operations"
' These functions would support "atomic" persistance changes
' (record-based create, update, delete, such as in a database).
' File-based persistance is a "batch" persistance mechanism,
' meaning ALL data (for a user) must be saved at once.
' Add your code to delete from database, registry, etc.
Private Shared Sub DeleteDataItem(ByVal Setting As SettingData)
Throw New Exception("DeleteDataItem is not coded!")
End Sub
' Add your code to save to database, registry, etc.
Private Shared Sub SaveNewDataItem(ByVal Setting As SettingData)
Throw New Exception("SaveNewDataItem is not coded!")
End Sub
' Add your code to update database, registry, etc.
Private Shared Sub UpdateDataItem(ByVal Setting As SettingData)
Throw New Exception("UpdateDataItem is not coded!")
End Sub
#End Region
End Class
Submit an article or tip