hi I made this for getting used to using Instr and Mid and other string functions, It a very simple Markup Language, that I wanted to make so i can do my own config files.
anyway I hope someone finds the code usfull.
Ok to get this working you need to add a new class to vb and call it clsCfg Then add this code to the class
Here is a simple config file I used for testingCode:'Bens Markup Language Private m_Col As New Collection Public Function ReadValue(ByVal Selection As String, ByVal Key As String, Optional Default As String = "") As String Dim Count As Long Dim sLine As String Dim sPos As Integer Dim ePos As Integer Dim eStart As Integer Dim eEnd As Integer Dim StartTag As String Dim EndTag As String Dim RetVal As String For Count = 1 To m_Col.Count sLine = m_Col(Count) 'Get opening tag sPos = InStr(1, sLine, "<?", vbTextCompare) ePos = InStr(1, sLine, ">", vbTextCompare) ' If (sPos > 0) And (ePos > 0) Then 'Check that the selection is found If LCase$(Mid$(sLine, sPos + 2, ePos - sPos - 2)) = LCase(Selection) Then 'Tag start position eStart = (Count + 1) Exit For End If End If Next Count 'Check if we have a start If (eStart = 0) Then 'Just return default value and exit ReadValue = Default Exit Function End If For Count = eStart To m_Col.Count sLine = m_Col(Count) 'Check for end selection sPos = InStr(1, sLine, "<?", vbTextCompare) ePos = InStr(1, sLine, "/>", vbTextCompare) If (sPos > 0) And (ePos > 0) Then 'Check that the selection is found If LCase$(Mid$(sLine, sPos + 2, ePos - sPos - 2)) = LCase(Selection) Then eEnd = (Count - 1) Exit For End If End If Next Count 'Get the value If (eStart > 0) And (eEnd > 0) Then For Count = eStart To eEnd sLine = m_Col(Count) 'Start tag StartTag = "<" & Key & ">" 'End tag EndTag = "</" & Key & ">" 'Check for open tag sPos = InStr(1, sLine, StartTag, vbTextCompare) ePos = InStr(1, sLine, EndTag, vbTextCompare) 'Check that we found the tags If (sPos > 0) And (ePos > 0) Then 'Extract the value between the tags RetVal = Mid$(sLine, sPos + Len(StartTag), ePos - Len(EndTag)) End If Next Count End If ReadValue = IIf(Len(RetVal), RetVal, Default) 'Clear up sLine = vbNullString RetVal = vbNullString StartTag = vbNullString EndTag = vbNullString End Function Public Sub LoadConfig(ByVal Filename As String) Dim fp As Long Dim sLine As String fp = FreeFile Set m_Col = Nothing Open Filename For Input As #fp Do Until EOF(fp) Line Input #fp, sLine 'Trim down the line sLine = LTrimWhite(sLine) 'Don't add comments If Left$(sLine, 3) = "<--" Then 'Bring in next line Line Input #fp, sLine End If 'Check for length If Len(sLine) Then Call m_Col.Add(sLine) End If DoEvents Loop Close #fp End Sub Private Function LTrimWhite(ByVal sString As String) As String Dim Count As Long Dim c As String 'This is like LTrim but works with tabs For Count = 1 To Len(sString) c = Mid$(sString, Count, 1) If (c <> " ") And (c <> vbTab) Then Exit For End If Next Count LTrimWhite = Mid$(sString, Count) End Function
put this into a new file in C:\test.bml
And here is an example using the class.Code:<?General> <Backcolor>Red</BackColor> <Enabled>True</Enabled> <?General/> <--This is a comment line--> <?Main> <Path>C:\Windows\</Path> <?Main/>
Code:Dim MyCfg As clsCfg 'Create the object Set MyCfg = New clsCfg 'Load example filename Call MyCfg.LoadConfig("C:\test.bml") 'Display a value form the general selection MsgBox MyCfg.ReadValue("general", "Backcolor") 'Display a value form the main selection MsgBox MyCfg.ReadValue("main", "path") 'Here an example if a value does not exsit we can use default MsgBox MyCfg.ReadValue("main", "ThisValueIsNotHere", "Testing Default Value")




Reply With Quote