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 iniAs New IniFileDim secsAs SectionsDim kvpsAs KeyValuePairsSet secs = ini.OpenIni("C:\Windows\ODBCINST.INI" )For i = 0To secs.Count - 1Debug ."[" ; secs.Item(i).Name;"]" Set kvps = secs.Item(i).KeyValuesFor j = 0To kvps.Count - 1Debug ."=" ; kvps.Item(j).ValueNext Debug .Next Debug .'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" ).ValueDebug ."Returned value from " "[Firebird/InterBase(r) driver]\Driver" " => " ; driverNameEnd Sub
Varolan bir dosyayı açarak içeriği değiştirme:
Public Sub TestUpdateAndSave()Dim iniAs New IniFileDim secsAs SectionsDim secAs SectionSet 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 iniAs New IniFileDim secsAs Sections, secAs SectionSet secs = ini.CreateNewSet 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 secsAs Sections, m_fileNameAs 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 filenameAs String )As Sections m_fileName = filenameCall InternalLoadIni(filename)Set OpenIni = secsEnd Function Public Function CreateNew()As Sections m_fileName = filenameSet CreateNew = secsEnd Function Public Sub Save(ByVal filenameAs String ,Optional overwriteAs Boolean =True )Dim streamAs New ADODB.stream, stream2As 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"" , 1Dim secAs Section, kvpAs KeyValuePairFor i = 0To secs.Count - 1Set sec = secs.Item(i) stream.WriteText"[" & sec.Name &"]" , 1For j = 0To sec.KeyValues.Count - 1Set kvp = sec.KeyValues.Item(j) stream.WriteText kvp.Key &"=" & kvp.Value, 1Next stream.WriteText"" , 1Next stream.Position = 3'Skip BOM stream.CopyTo stream2 stream2.SaveToFile filename, IIf(overwrite, 2, 1) stream.Flush: stream2.Flush stream.Close: stream2.CloseEnd Sub Private Sub InternalLoadIni(ByVal filenameAs String )Dim textOfLineAs String , secNameAs String , secAs SectionDim KeyAs String , ValueAs String Const SEPERATOR1 ="=" Const SEPERATOR2 =":" Dim streamAs New ADODB.stream stream.Charset ="utf-8" stream.Type = 2 stream.Open stream.LoadFromFile filenameDo 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 > 0Then 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.CloseEnd Sub Private Sub GetKeyValue(ByVal textAs String ,ByVal separatorAs String ,ByRef KeyAs String ,ByRef ValueAs String )Dim indexAs Integer index = InStr(1, text, separator)If index = 0Then 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 SectionsEnd Sub
2-) Sections.cls
Private dicAs Object , m_items, m_keysPublic Function Add(ByVal sectionNameAs String )As SectionIf Not dic.Exists(sectionName)Then Dim kvcAs New Section kvc.Name = sectionNameCall dic.Add(sectionName, kvc) m_keys = dic.Keys m_items = dic.ItemsSet Add = kvcEnd If End Function Public Sub Remove(ByVal indexOrSectionName)If TypeName(indexOrSectionName) ="String" Then dic.Remove indexOrSectionNameElse Dim kAs String k = m_keys(indexOrSectionName) dic.Remove k m_keys = dic.Keys m_items = dic.ItemsEnd If End Sub Public Property Get Count()As Integer Count = dic.CountEnd Property Public Property Get Item(ByVal indexAs Integer )As SectionIf dic.Count > indexThen Set Item = m_items(index)End If End Property Public Property Set Item(ByVal indexAs Integer , ValueAs Section)If dic.Count > indexThen Dim kAs String k = m_keys(index)Set dic(k) = ValueEnd If End Property Public Property Get ItemByName(ByVal sectionNameAs String )As SectionIf dic.Exists(sectionName)Then Set ItemByName = dic(sectionName)End If End Property Public Property Set ItemByName(ByVal sectionNameAs String , ValueAs Section)If dic.Exists(sectionName)Then Set dic(sectionName) = ValueEnd If End Property Private Sub Class_Initialize()Set dic = CreateObject("Scripting.Dictionary" ) dic.CompareMode = TextCompareEnd Sub
3-) Section.cls
Private kvpsAs KeyValuePairs, m_NameAs String Public Property Get KeyValues()As KeyValuePairsSet KeyValues = kvpsEnd Property Public Property Get Name()As String Name = m_NameEnd Property Public Property Let Name(ByVal ValueAs String ) m_Name = ValueEnd Property Private Sub Class_Initialize()Set kvps =New KeyValuePairsEnd Sub
4-) KeyValuePairs.cls
Private dicAs Object , m_keys, m_itemsPublic Function Add(ByVal vKeyAs String , vValueAs String )As KeyValuePairIf Not dic.Exists(Key)Then Dim kvpAs New KeyValuePair kvp.Key = vKey kvp.Value = vValueCall dic.Add(vKey, kvp) m_keys = dic.Keys m_items = dic.ItemsSet Add = kvpEnd If End Function Public Sub Remove(ByVal indexOrKeyName)If TypeName(indexOrKeyName) ="String" Then dic.Remove indexOrKeyNameElse Dim kAs String k = m_keys(indexOrKeyName) dic.Remove k m_keys = dic.Keys m_items = dic.ItemsEnd If End Sub Public Property Get Count()As Integer Count = dic.CountEnd Property Public Property Get Item(ByVal indexAs Integer )As KeyValuePairIf dic.Count > indexThen Set Item = m_items(index)End If End Property Public Property Set Item(ByVal indexAs Integer ,ByVal vValueAs KeyValuePair)If dic.Count > indexThen Dim kAs String k = m_keys(index)Set dic(k) = vValueEnd If End Property Public Property Get ItemByKey(ByVal vKeyAs String )As KeyValuePairIf dic.Exists(vKey)Then Set ItemByKey = dic(vKey)End If End Property Public Property Set ItemByKey(ByVal vKeyAs String ,ByVal vValueAs KeyValuePair)If dic.Exists(Key)Then Set dic(vKey) = vValueEnd If End Property Private Sub Class_Initialize()Set dic = CreateObject("Scripting.Dictionary" ) dic.CompareMode = TextCompareEnd Sub
5-) KeyValuePair.cls
Private m_keyAs String , m_valueAs String Public Property Get Key()As String Key = m_keyEnd Property Public Property Let Key(ByVal vKeyAs String ) m_key = vKeyEnd Property Public Property Get Value()As String Value = m_valueEnd Property Public Property Let Value(ByVal vValueAs String ) m_value = vValueEnd Property
Ne diyeyim .... hem "class" bir o kadar da "klâs" bir makale ve kod.....
YanıtlaSilTeşekkür ederim dostum. Beğendiğine sevindim.
Sil