Read/Write Ini files Parser in VBA

     Günümüzde modern yapılandırma/ayar dosyası olarak XML veya JSON kullanılıyor olsa da, bazen INI dosyalarına ihtiyaç duyulabiliyor. Konuyla ilgili VBA class modullerini kullanarak Kernel32.dll fonksiyonlarına gereksinimi olmayan nesne hazırladım.

    INI dosyaları notepad uygulaması ile okunabilen bir dosyadır. Dosyayı açtığınızda aşağıdaki gibi içeriğe sahip olduğunu görürsünüz. Köşeli parantez ifadeler Section, hemen altındaki satırlar ise key=value biçimindeki verilerdir. Bazı parser'larda "=" yerine ":" kullanılabilmektedir.

[Application] ;Application info section
Name=MyApp.exe
Path=C:\ProgramFiles\MyApp

[Settings] ;Application settings section
ShowMainPage=1
FloatMenuPos=250,25

    Kimilerine göre INI dosyalarıyla çalışmak gereksiz görebilirse de, bu başlık class modul ile nesne hazırlama konusunda fikir verebilir.

    Aşağıdaki resimde de görüldüğü gibi VBA Parser 5 sınıftan oluşuyor. IniFile sınıfı ile yeni bir dosya oluşturulabilir veya mevcut bir dosya açılarak değiştirilerek üzerine veya farklı bir ad ile kaydedilebilir.

 Dosya açarak içeriği okuma:

Sub TestOpenAndEnumarate()
    Dim ini As New IniFile
    Dim secs As Sections
    Dim kvps As KeyValuePairs
    
    Set secs = ini.OpenIni("C:\Windows\ODBCINST.INI")
   
    For i = 0 To secs.Count - 1
        Debug.Print "["; secs.Item(i).Name; "]"

        Set kvps = secs.Item(i).KeyValues

        For j = 0 To kvps.Count - 1
            Debug.Print kvps.Item(j).Key; "="; kvps.Item(j).Value
        Next

        Debug.Print

    Next
    
    Debug.Print
    
    'Read specific key from spesific section
    'If -Firebird/InterBase(r) driver- installed on your pc
    Set sec = secs.ItemByName("Firebird/InterBase(r) driver")
    driverName = sec.KeyValues.ItemByKey("Driver").Value
    Debug.Print "Returned value from ""[Firebird/InterBase(r) driver]\Driver"" => "; driverName
    
End Sub

 Varolan bir dosyayı açarak içeriği değiştirme:

Public Sub TestUpdateAndSave()
    Dim ini As New IniFile
    Dim secs As Sections
    Dim sec As Section
    
    Set secs = ini.OpenIni(Environ$("userprofile") & "\Desktop\MyIni.ini")
    
    'Value update.
    secs.ItemByName("Menus").KeyValues.ItemByKey("File").Value = "Visible-Updated"
    
    'Key update
    secs.ItemByName("Menus").KeyValues.ItemByKey("Print").Key = "PrintPreview-Updated"
    
    'New section and add key & value
    Set sec = secs.Add("NewSection")
    sec.KeyValues.Add "NewKey", "NewValue"
    
    ini.Save Environ$("userprofile") & "\Desktop\NewMyIni.ini"
    
    'or update it.
    'ini.Save Environ$("userprofile") & "\Desktop\MyIni.ini"
End Sub

Yeni bir dosya oluşturma:

Sub TestCreate()
    Dim ini As New IniFile
    Dim secs As Sections, sec As Section
    
    Set secs = ini.CreateNew
    
    Set sec = secs.Add("Settings")
    sec.KeyValues.Add "Color", "Red"
    
    Set sec = secs.Add("Menus")
    sec.KeyValues.Add "File", "Visible"
    sec.KeyValues.Add "Print", "Invisible"
    
    ini.Save Environ$("userprofile") & "\Desktop\MyIni.ini"
    
End Sub

Kaynak kodlar:

1-) IniFile.cls

Private secs As Sections, m_fileName As String

'///////////////////////////////////////////////////////////
'/                                                         /
'/ Author: Zeki Gürsoy - 06.01.2021 - gursoyzeki@gmail.com /
'/ More information about ini files:                       /
'/     https://en.wikipedia.org/wiki/INI_file              /
'/                                                         /
'///////////////////////////////////////////////////////////

Public Function OpenIni(ByVal filename As String) As Sections
    m_fileName = filename
    Call InternalLoadIni(filename)
    Set OpenIni = secs
End Function

Public Function CreateNew() As Sections
    m_fileName = filename
    Set CreateNew = secs
End Function

Public Sub Save(ByVal filename As String, Optional overwrite As Boolean = True)
    Dim stream As New ADODB.stream, stream2 As New ADODB.stream
    
    stream2.Charset = "utf-8"
    stream2.Type = 1 'Binary
    stream2.Open
    
    stream.Type = 2 'Text
    stream.Charset = "utf-8"
    stream.Open
    
    stream.WriteText ";Generated by IniFile VBA class", 1
    stream.WriteText ";Create/Update at : " & Format(Now, "mm\/dd\/yyyy hh:mm:ss"), 1
    stream.WriteText ";Zeki Gürsoy - 06.01.2021 - gursoyzeki@gmail.com", 1
    stream.WriteText "", 1
    
    Dim sec As Section, kvp As KeyValuePair
    
    For i = 0 To secs.Count - 1
        Set sec = secs.Item(i)
        
        stream.WriteText "[" & sec.Name & "]", 1
        
        For j = 0 To sec.KeyValues.Count - 1
            Set kvp = sec.KeyValues.Item(j)
            stream.WriteText kvp.Key & "=" & kvp.Value, 1
        Next
        
        stream.WriteText "", 1
        
    Next
    
    stream.Position = 3 'Skip BOM
    stream.CopyTo stream2
    stream2.SaveToFile filename, IIf(overwrite, 2, 1)
    
    stream.Flush: stream2.Flush
    stream.Close: stream2.Close
    
End Sub

Private Sub InternalLoadIni(ByVal filename As String)
    Dim textOfLine As String, secName As String, sec As Section
    Dim Key As String, Value As String
    
    Const SEPERATOR1 = "="
    Const SEPERATOR2 = ":"
    
    Dim stream As New ADODB.stream
    
    stream.Charset = "utf-8"
    stream.Type = 2
    stream.Open
    stream.LoadFromFile filename
    
    Do While Not stream.EOS
    
        textOfLine = Trim(stream.ReadText(-2)) 'Line by line
        
        Key = "": Value = ""
                
        Select Case Left(textOfLine, 1)
            Case ";", "#", "" 'this is a comment or variable or empty line
            Case "["          'this is a section, OK
                rBracket = InStr(1, textOfLine, "]")
                secName = Mid$(textOfLine, 2, rBracket - 2)
                Set sec = secs.Add(secName)
            Case Else         'this is a key and value, OK
                rComment = InStr(1, textOfLine, ";")
                
                If rComment > 0 Then textOfLine = Trim$(Left$(textOfLine, rComment))
                
                Call GetKeyValue(textOfLine, SEPERATOR1, Key, Value)
                
                'Some implementions may use ":" seperator.
                'Will try this if "=" seperator is nothing.
                If Key = "" Then Call GetKeyValue(textOfLine, SEPERATOR2, Key, Value)
                
                Call sec.KeyValues.Add(Key, Value)
        End Select
    
    Loop
    
    stream.Flush
    stream.Close
End Sub

Private Sub GetKeyValue(ByVal text As String, ByVal separator As String, ByRef Key As String, ByRef Value As String)
    Dim index As Integer
    
    index = InStr(1, text, separator)
    
    If index = 0 Then Exit Sub
    
    If Mid$(text, index - 1, 1) = "\" Then Exit Sub
    
    Key = Trim$(Left$(text, index - 1))
    Value = Trim$(Right$(text, Len(text) - index))
End Sub

Private Sub Class_Initialize()
    Set secs = New Sections
End Sub

 

2-) Sections.cls

Private dic As Object, m_items, m_keys

Public Function Add(ByVal sectionName As String) As Section
    If Not dic.Exists(sectionName) Then
    
        Dim kvc As New Section
        
        kvc.Name = sectionName
        
        Call dic.Add(sectionName, kvc)
        
        m_keys = dic.Keys
        m_items = dic.Items
        
        Set Add = kvc
        
    End If
End Function

Public Sub Remove(ByVal indexOrSectionName)
    If TypeName(indexOrSectionName) = "String" Then
        dic.Remove indexOrSectionName
    Else
        Dim k As String
        
        k = m_keys(indexOrSectionName)
        dic.Remove k
        
        m_keys = dic.Keys
        m_items = dic.Items
    End If
End Sub

Public Property Get Count() As Integer
    Count = dic.Count
End Property

Public Property Get Item(ByVal index As Integer) As Section
    If dic.Count > index Then
        Set Item = m_items(index)
    End If
End Property

Public Property Set Item(ByVal index As Integer, Value As Section)
    If dic.Count > index Then
        Dim k As String
        
        k = m_keys(index)
        Set dic(k) = Value
    End If
End Property

Public Property Get ItemByName(ByVal sectionName As String) As Section
    If dic.Exists(sectionName) Then
        Set ItemByName = dic(sectionName)
    End If
End Property

Public Property Set ItemByName(ByVal sectionName As String, Value As Section)
    If dic.Exists(sectionName) Then
        Set dic(sectionName) = Value
    End If
End Property

Private Sub Class_Initialize()
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = TextCompare
End Sub

 

3-) Section.cls

Private kvps As KeyValuePairs, m_Name As String

Public Property Get KeyValues() As KeyValuePairs
    Set KeyValues = kvps
End Property

Public Property Get Name() As String
    Name = m_Name
End Property

Public Property Let Name(ByVal Value As String)
    m_Name = Value
End Property

Private Sub Class_Initialize()
    Set kvps = New KeyValuePairs
End Sub

 

4-) KeyValuePairs.cls

Private dic As Object, m_keys, m_items

Public Function Add(ByVal vKey As String, vValue As String) As KeyValuePair
    If Not dic.Exists(Key) Then
        Dim kvp As New KeyValuePair
        
        kvp.Key = vKey
        kvp.Value = vValue
        
        Call dic.Add(vKey, kvp)
        
        m_keys = dic.Keys
        m_items = dic.Items
        
        Set Add = kvp
    End If
End Function

Public Sub Remove(ByVal indexOrKeyName)
    If TypeName(indexOrKeyName) = "String" Then
        dic.Remove indexOrKeyName
    Else
        Dim k As String
        
        k = m_keys(indexOrKeyName)
        dic.Remove k
        
        m_keys = dic.Keys
        m_items = dic.Items
    End If
End Sub

Public Property Get Count() As Integer
    Count = dic.Count
End Property

Public Property Get Item(ByVal index As Integer) As KeyValuePair
    If dic.Count > index Then
        Set Item = m_items(index)
    End If
End Property

Public Property Set Item(ByVal index As Integer, ByVal vValue As KeyValuePair)
    If dic.Count > index Then
        Dim k As String
        
        k = m_keys(index)
        Set dic(k) = vValue
    End If
End Property

Public Property Get ItemByKey(ByVal vKey As String) As KeyValuePair
    If dic.Exists(vKey) Then
        Set ItemByKey = dic(vKey)
    End If
End Property

Public Property Set ItemByKey(ByVal vKey As String, ByVal vValue As KeyValuePair)
    If dic.Exists(Key) Then
        Set dic(vKey) = vValue
    End If
End Property

Private Sub Class_Initialize()
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = TextCompare
End Sub

 

5-) KeyValuePair.cls

Private m_key As String, m_value As String

Public Property Get Key() As String
    Key = m_key
End Property

Public Property Let Key(ByVal vKey As String)
    m_key = vKey
End Property

Public Property Get Value() As String
    Value = m_value
End Property

Public Property Let Value(ByVal vValue As String)
    m_value = vValue
End Property