VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "clsConfiguration" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False ' ==================================================================================== ' INTRODUCTION ' ==================================================================================== ' ' Configuration Class Module by Pascal vd Heiden, www.codeimp.com ' ' This Class module contains code of my design. You are free to use it, ' as long as you do not remove my details up here in this comment. Thanks. ' ' This Class module requires "Microsoft Scripting Runtime" reference (scrrun.dll) ' for the Dictionary object. Select this in the Project -> References dialog. ' ' Can safely be compiled with Fast Optimization and ' all Advanced Optimization switches checked. ' ' ' ==================================================================================== ' CONFIGURATION FILE STRUCTURE SYNTAX ' ==================================================================================== ' ' Whitepace is always allowed. This includes spaces, tabs ' linefeeds (10) and carriage returns (13) ' ' Keys may not have spaces or assignment operator = in them. ' ' Comments start with // (unless used within strings) ' and count as comment for the rest of the line. Or use /* and */ ' to mark the beginning and end of a comment. ' ' Simple setting: ' ' key = value; ' ' Example: speed = 345; ' cars = 8; ' ' Strings must be in quotes. ' ' Example: nickname = "Gherkin"; ' altnick = "Gherk inn"; ' ' String Escape Sequences: ' \n New line (10) ' \r Carriage return (13) ' \t Tab (9) ' \" Double-quotation mark ' \\ Backslash ' \000 Any ASCII character (MUST be 3 digits! So for 13 you use \013) ' ' Decimals ALWAYS use a dot, NEVER comma! ' ' Example: pressure = 15.29; ' acceleration = 1.0023; ' ' Structures must use brackets. ' ' Structure Example: ' ' key ' { ' key = value; ' key = value; ' ' key ' { ' key = value; ' key = value; ' key = value; ' } ' ' key = value; ' key = value; ' key = value; ' key = value; ' key = value; ' } ' ' As you can see, structures inside structures are allowed ' and you may go as deep as you want. Note that only the root structures ' can be readed from config using ReadSetting. ReadSetting will return a ' Dictionary object containing everything in that root structure. ' ' Key names must be unique within their scope. ' ' This is NOT allowed, it may not have 'father' more ' than once in the same scope: ' ' mother = 45; ' father = 52; ' ' father ' { ' length = 1.87; ' } ' ' This however is allowed, because father ' now exists in a different scope: ' ' mother = 45; ' father = 52; ' ' parents ' { ' father = 52; ' } ' ' This too is allowed, both 'age' are in a different scope: ' ' mother ' { ' age = 45; ' } ' ' father ' { ' age = 52; ' } ' ' ' ==================================================================================== ' FUNCTION CALL DESCRIPTIONS ' ==================================================================================== ' ' InputConfiguration ' ' This loads a configuration from a string. The string must contain a ' configuration using the rules described above. ' ' ------------------------------------------------------------------------------------ ' ' LoadConfiguration ' ' Loads a configuration from a file. The file must contain a configuration ' using the rules described above. ' ' ------------------------------------------------------------------------------------ ' ' NewConfiguration ' ' Erases all loaded settings and starts with a new, clear configuration ' ' ------------------------------------------------------------------------------------ ' ' OutputConfiguration ' ' Returns the configuration as a string following the rules described above. ' You can optionally determine the newline character to use and/or omit ' whitespace in the result. ' ' ------------------------------------------------------------------------------------ ' ' SaveConfiguration ' ' Writes the configuration to file following the rules described above. ' You can optionally specify the newline character to use and/or omit ' whitespace in the result. ' ' ------------------------------------------------------------------------------------ ' ' ReadSetting ' ' Reads a setting from the root level and returns it in its own variable type. ' You can optionally specify a default to return if the specified setting ' does not exist and/or specify if you would like to get a reference if the ' setting is a Dictionary object (structure in configuration). ' If you use a reference, you can change the configuration immediately ' through that reference. ' ' ------------------------------------------------------------------------------------ ' ' WriteSetting ' ' Writes a setting to the root level in the configuration. ' You can choose to write the setting as reference if it is of Dictionary type. ' Note that your configuration changes too when you change anything ' in your Dictionary when it is written as reference! ' ' ------------------------------------------------------------------------------------ ' ' RemoveSetting ' ' Removes a setting from the root level in the configuration. ' Its as simple as that. What else is there to tell about it?! ' ' ------------------------------------------------------------------------------------ ' ' Root ' ' Returns the entire configuration (root level) as a Dictionary object. ' You can optionally specify to return a reference through which you can change ' the configuration immediately. ' ' ==================================================================================== ' ==================================================================================== 'Do not allow any undeclared variables Option Explicit 'Case sensitive comparisions Option Compare Binary Private Const ASSIGNOP As Long = 61 ' = Private Const BEGINOP As Long = 123 ' { Private Const ENDOP As Long = 125 ' } Private Const TERMINATEOP As Long = 59 ' ; Private Const STRINGOP As Long = 34 ' " Private Const COMMENT As String = "//" ' Private Const BEGINCOMMENT As String = "/*" ' Private Const ENDCOMMENT As String = "*/" ' Private Const WS_SPACE As Long = 32 ' space Private Const WS_LINEFEED As Long = 10 ' linefeed Private Const WS_TAB As String = vbTab ' Private Const WS_RETURN As String = vbCr ' Private Const ESCAPESEQ As Long = 92 ' \ Private Const ES_NEWLINE As Long = 110 ' n Private Const ES_RETURN As Long = 114 ' r Private Const ES_TAB As Long = 116 ' t Private Const ES_QUOTE As Long = 34 ' " Private Const ES_BACKSLASH As Long = 92 ' \ 'This will hold the object orientated configuration Private Config As Dictionary 'Last line that was read where error occurred Private cLastReadLine As Long Public Property Get CurrentScanLine() As Long CurrentScanLine = cLastReadLine End Property Private Sub Class_Initialize() 'New database Set Config = New Dictionary End Sub Private Sub Class_Terminate() 'Clean up Set Config = Nothing End Sub Private Function DeepCopy(ByRef Dict As Dictionary) As Dictionary Dim NewConfig As Dictionary Dim CopyObject As Dictionary Dim ConfigKeys As Variant Dim ConfigValue As Variant Dim i As Long 'Create new config Set NewConfig = New Dictionary 'Add all items from Config If Dict.Count Then ConfigKeys = Dict.Keys For i = LBound(ConfigKeys) To UBound(ConfigKeys) 'Check if the value is a dictionary If VarType(Dict(ConfigKeys(i))) = vbObject Then 'Get the object Set CopyObject = Dict(ConfigKeys(i)) 'Deepcopy this too NewConfig.Add ConfigKeys(i), DeepCopy(CopyObject) 'Clean up Set CopyObject = Nothing Else 'Normal copy ConfigValue = Dict(ConfigKeys(i)) NewConfig.Add ConfigKeys(i), ConfigValue End If Next i End If 'Return the result Set DeepCopy = NewConfig 'Clean up Set NewConfig = Nothing End Function Private Function Escaped(ByRef Value As String) As String ' \n New line ' \r Carriage return ' \t Tab ' \" Double quotation mark ' \\ Backslash 'Copy string Escaped = Value 'Replace characters with escape sequences Escaped = Replace$(Escaped, "\", "\\") 'Note the \ must be the first to replace! Escaped = Replace$(Escaped, vbLf, "\n") Escaped = Replace$(Escaped, vbCr, "\r") Escaped = Replace$(Escaped, vbTab, "\t") Escaped = Replace$(Escaped, """", "\""") End Function Public Sub InputConfiguration(ByVal Configuration As String) 'This reads the data and builds a new dictionary object 'Remove Returns and Tabs so we only have Linefeed as newline Configuration = Replace$(Configuration, WS_RETURN, "") Configuration = Replace$(Configuration, WS_TAB, "") 'First line cLastReadLine = 1 'Load main structure Set Config = LoadStructure(0, Configuration) End Sub Public Sub LoadConfiguration(ByRef Filename As String) Dim FB As Integer 'File buffer Dim Data As String 'Data 'This reads a file and builds a new dictionary object 'Open the file to read FB = FreeFile Open Filename For Binary As #FB 'Read all data Data = Space$(LOF(FB)) Get #FB, 1, Data 'Close file Close #FB 'Remove Returns and Tabs so we only have Linefeed as newline Data = Replace$(Data, WS_RETURN, "") Data = Replace$(Data, WS_TAB, "") 'First line cLastReadLine = 1 'Load main structure Set Config = LoadStructure(0, Data) End Sub Private Function LoadStructure(ByRef p As Long, ByRef Data As String) As Dictionary Dim c As String * 1 'Character at p Dim ca As Long 'ASCII value of c Dim np As Long 'Next position Dim StringData As Boolean 'True if in a string Dim NumberData As Boolean 'True if in a number Dim Sequence As Boolean 'True if getting a sequence character Dim Assigning As Boolean 'True when assigning Dim NewKey As String Dim NewValue As String 'Create dictionary Set LoadStructure = New Dictionary 'Continue until end of data Do While p < Len(Data) 'Next char p = p + 1 'Get char c = Mid$(Data, p, 1) ca = AscW(c) 'Check if we are processing number data If NumberData Then 'Check if assignment ends If ca = TERMINATEOP Then 'Check number type If InStr(NewValue, ".") <> 0 Then 'Add the number to dictionary as single LoadStructure.Add Trim$(NewKey), CSng(Val(NewValue)) Else 'Add the number to dictionary as long LoadStructure.Add Trim$(NewKey), CLng(NewValue) End If 'Reset NewKey = "" NewValue = "" 'End of assign NumberData = False Assigning = False 'Check if newline ElseIf (ca = WS_LINEFEED) Then 'Count the new line cLastReadLine = cLastReadLine + 1 Else 'Add to value NewValue = NewValue & c End If 'Check if we are processing string data ElseIf StringData Then 'Check if previous char was a slash If Sequence Then 'Check the char Select Case ca Case ES_BACKSLASH: NewValue = NewValue & "\" Case ES_NEWLINE: NewValue = NewValue & vbLf Case ES_QUOTE: NewValue = NewValue & """" Case ES_RETURN: NewValue = NewValue & vbCr Case ES_TAB: NewValue = NewValue & vbTab Case Else 'Check if its a number If IsNumeric(c) Then 'Always 3 chars np = CLng(Mid$(Data, p, 3)) NewValue = NewValue & ChrW$(np) p = p + 2 Else 'Add character NewValue = NewValue & c End If End Select 'End of sequence Sequence = False Else 'Check if sequence start If ca = ESCAPESEQ Then 'Start escape sequence Sequence = True 'Check if string ends ElseIf ca = STRINGOP Then 'Add the string to dictionary LoadStructure.Add Trim$(NewKey), NewValue 'End of string StringData = False 'Reset NewKey = "" NewValue = "" 'Check if newline ElseIf (ca = WS_LINEFEED) Then 'Count the new line cLastReadLine = cLastReadLine + 1 Else 'Add to string NewValue = NewValue & c End If End If 'Check if assigning ElseIf Assigning Then 'Check for STRINGOP or Numeric character If (ca = STRINGOP) Then 'Begin string data here StringData = True ElseIf (IsNumeric(c) = True) Or (c = "-") Or (c = ".") Or (LCase$(c) = "e") Or (c = "&") Then 'Begin numeric data here NumberData = True 'Note that this byte is part of the value p = p - 1 'Check if newline ElseIf (ca = WS_LINEFEED) Then 'Count the new line cLastReadLine = cLastReadLine + 1 'Check if assignment ends ElseIf (ca = TERMINATEOP) Then 'End of assign Assigning = False 'Everything else but spaces are not allowed ElseIf (ca <> WS_SPACE) Then 'Invalid assignment Err.Raise vbObjectError, , "Invalid assignment. Forgot an assignment terminator?" End If 'Anything else Else 'If (ca <> WS_SPACE) Then 'Check for a Key, BEGINOP, ENDOP or ASSIGNOP, COMMENT or whitespace Select Case ca Case BEGINOP 'Check for spaces in key name If (InStr(Trim$(NewKey), " ") > 0) Then 'Spaces not allowed in key names Err.Raise vbObjectError, , "Spaces not allowed in key names." Else 'Add structure LoadStructure.Add Trim$(NewKey), LoadStructure(p, Data) 'Reset NewKey = "" End If Case ENDOP 'Leave here Exit Do Case ASSIGNOP 'Check for spaces in key name If (InStr(Trim$(NewKey), Chr$(WS_SPACE)) > 0) Then 'Spaces not allowed in key names Err.Raise vbObjectError, , "Spaces not allowed in key names." Else 'Now assigning Assigning = True End If Case TERMINATEOP 'Add the key to dictionary with 0 value LoadStructure.Add Trim$(NewKey), CLng(0) 'Reset NewKey = "" NewValue = "" Case WS_LINEFEED 'Count the new line cLastReadLine = cLastReadLine + 1 'Add as space NewKey = NewKey & Chr$(WS_SPACE) 'Check for possible comment Case AscW(COMMENT), AscW(BEGINCOMMENT) 'Check for 2 bytes line comment If Mid$(Data, p, 2) = COMMENT Then 'Find the next linefeed np = InStr(p, Data, vbLf) 'Check if linefeed was found If np > 0 Then 'Count linefeed cLastReadLine = cLastReadLine + 1 'Skip to next p = np Else 'No linefeed can be found, end of file! p = Len(Data) Exit Do End If 'Check for 2 bytes block comment ElseIf Mid$(Data, p, 2) = BEGINCOMMENT Then 'Find the next endcomment np = InStr(p, Data, ENDCOMMENT) 'Check if endcomment was found If np > 0 Then 'Count the number of linefeeds in comment block cLastReadLine = cLastReadLine + UBound(Split(Mid$(Data, p, np - p), Chr$(WS_LINEFEED))) 'Skip to next p = np + 1 Else 'No endcomment can be found, end of file! p = Len(Data) Exit Do End If End If 'Add to key name Case Else: NewKey = NewKey & c End Select End If Loop End Function Public Sub NewConfiguration() 'First line cLastReadLine = 1 'Create new, empty dictionary Set Config = New Dictionary End Sub Public Function OutputConfiguration(Optional ByVal NewLine As String = vbCrLf, Optional ByVal Whitespace As Boolean = True) As String 'Create configuration as string OutputConfiguration = OutputDictionary(Config, 0, NewLine, Whitespace) End Function Private Function OutputDictionary(ByRef Dict As Dictionary, ByVal Level As Long, Optional ByVal NewLine = vbCrLf, Optional ByVal Whitespace As Boolean = True) As String Dim LevelTabs As String Dim sp As String Dim Keys As Variant Dim Data As String Dim i As Long 'Check if this dictionary is not empty If Dict.Count > 0 Then 'Create whitespace If Whitespace Then LevelTabs = String$(Level, vbTab) sp = " " End If 'Get the keys Keys = Dict.Keys 'Go for all keys in dictionary For i = LBound(Keys) To UBound(Keys) 'Check type of value Select Case VarType(Dict(Keys(i))) 'Dictionary Object Case vbObject 'Output empty line If Whitespace Then Data = Data & LevelTabs & NewLine 'Output the key Data = Data & LevelTabs & Keys(i) & NewLine 'Ouput the BEGINOP Data = Data & LevelTabs & ChrW$(BEGINOP) & NewLine 'Output Dictionary Data = Data & OutputDictionary(Dict(Keys(i)), Level + 1, NewLine, Whitespace) 'Output the ENDOP Data = Data & LevelTabs & ChrW$(ENDOP) & NewLine 'Output empty line If Whitespace Then Data = Data & LevelTabs & NewLine 'Integral Number Case vbInteger, vbLong, vbByte 'Output the key = value; Data = Data & LevelTabs & Keys(i) & sp & ChrW$(ASSIGNOP) & sp & Dict(Keys(i)) & ChrW$(TERMINATEOP) & NewLine 'Floating point Number Case vbSingle, vbDouble, vbCurrency, vbDecimal 'Output the key = value; Data = Data & LevelTabs & Keys(i) & sp & ChrW$(ASSIGNOP) & sp & Format(Dict(Keys(i)), "###############################0.0#####") & "f" & ChrW$(TERMINATEOP) & NewLine 'Boolean as Number Case vbBoolean 'Output the key = value; Data = Data & LevelTabs & Keys(i) & sp & ChrW$(ASSIGNOP) & sp & CLng(Dict(Keys(i))) & ChrW$(TERMINATEOP) & NewLine 'Other (String) Case Else 'Output the key = "value"; Data = Data & LevelTabs & Keys(i) & sp & ChrW$(ASSIGNOP) & sp & ChrW$(STRINGOP) & Escaped(Dict(Keys(i))) & ChrW$(STRINGOP) & ChrW$(TERMINATEOP) & NewLine End Select Next i End If 'Return data OutputDictionary = Data End Function Public Function ReadSetting(ByRef Setting As String, Optional ByRef Default As Variant, Optional ByVal Reference As Boolean) 'Check if setting exists If Config.Exists(Setting) Then 'Check setting type If VarType(Config(Setting)) = vbObject Then 'Check if we should return a reference If Reference Then 'Return a reference Set ReadSetting = Config(Setting) Else 'Return the setting Set ReadSetting = DeepCopy(Config(Setting)) End If Else 'Return the setting ReadSetting = Config(Setting) End If Else 'Return the default If VarType(Default) = vbObject Then Set ReadSetting = Default Else ReadSetting = Default End If End Function Public Sub RemoveSetting(ByRef Setting As String) 'Remove setting if exists If Config.Exists(Setting) Then Config.Remove Setting End Sub Public Function Root(Optional ByVal Reference As Boolean) As Dictionary 'Check if we should return a reference If Reference Then 'Return a reference Set Root = Config Else 'Return the setting Set Root = DeepCopy(Config) End If End Function Public Sub SaveConfiguration(ByRef Filename As String, Optional ByVal NewLine As String = vbCrLf, Optional ByVal Whitespace As Boolean = True) Dim FB As Integer 'File buffer Dim Data As String 'Data 'This reads a file and builds a new dictionary object 'Create data Data = OutputDictionary(Config, 0, NewLine, Whitespace) 'Kill the file if exists If Dir(Filename) <> "" Then Kill Filename 'Open the file to write FB = FreeFile Open Filename For Binary As #FB 'Write configuration data Put #FB, 1, Data 'Close file Close #FB End Sub Public Sub WriteSetting(ByRef Setting As String, ByRef Value As Variant, Optional ByVal Reference As Boolean) Dim DictValue As Dictionary 'Check if the setting exists If Config.Exists(Setting) Then 'Check type of value If VarType(Value) = vbObject Then 'Check if we should apply referenced If Reference Then 'Apply setting as reference Set Config(Setting) = Value Else 'Apply setting Set DictValue = Value Set Config(Setting) = DeepCopy(DictValue) 'Clean up Set DictValue = Nothing End If Else 'Apply setting Config(Setting) = Value End If Else 'Add setting Config.Add Setting, Value End If End Sub