headerbanner

VBA - využití Win API pro práci s INI soubory

VBA Excel - GetPrivateProfile.../WritePrivateProfile... Functions for INI Files

Pro manipulaci s INI soubory lze s výhodou použít existujících funkcí Win32 API. Často používaná sada funkcí  GetPrivateProfile.../WritePrivateProfile...  je sice již od Win 95 označována jako zastaralá a zachovávaná pouze pro zpětnou kompatibilitu s 16-bit Windows, ale doporučované přímé využití registru místo INI souborů je komplikovanější.

INI soubory jsou dobré například pro přenos aplikace na jiné počítače při změně jména uživatele. Měnit zdrojový kód při každé instalaci není zrovna čisté.

Googlením lze najít kompletní skripty, ale POZOR - v mnoha chybí nebo je špatný test na velikost zásobníku, který způsobí přečtení pouze části ini souboru. Microsoft upozorňuje: "If the buffer is not large enough to contain all the key name and value pairs associated with the named section, the return value is equal to nSize minus two." Jenže mnoho příkladů na inetu testuje návratovou hodnotu na "délka - 1" místo na "délka - 2". Způsobí to obtížně odhalitelné chyby.

Následující kompletní sada obsahuje správné testy.

V argumentech funkcí je jméno INI souboru. Pokud je vložen soubor s úplnou cestou, pracují funkce s daným souborem, ale když cesta neexistuje, vrací funkce False. Pokud je uvedeno samostatné jméno bez cesty, čtou "čtecí" funkce INI soubor daného jména v adresáři Windows, zapisovací funkce se pokusí ini soubor ve Windows adresáři vytvořit.

Chyby jsou ošetřeny přerušením Err.Raise s číslem chyby 1000, řádky s příslušným kódem je vhodné přepsat podle vašich zvyklostí. 

 
'následující deklarace musí být na začátku modulu
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal _
sectname As String, ByVal varname As String, ByVal defaultval _
As String, ByVal returnstr As String, ByVal ssize As Long, ByVal _
inifilename As String) As Long
 
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal _
 sectname As String, ByVal varname As String, ByVal defaultval _
 As Long, ByVal inifilename As String) As Long
 
Private Declare Function GetPrivateProfileSection Lib "kernel32" Alias "GetPrivateProfileSectionA" _
 (ByVal lpAppName As String, ByVal returnstr As String, ByVal _
 ssize As Long, ByVal inifilename As String) As Long
 
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
 (ByVal sectname As String, ByVal varname As String, ByVal _
 strval As String, ByVal inifilename As String) As Long
 
Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" _
 (ByVal lpAppName As String, ByVal strval As String, ByVal inifilename _
As String) As Long
 
Public Const defnum_ As Long = -99999 'defaultní návrat pro getIniNumVal
Public Const buff_ As Long = 1024 'nejmenší délka bufferu pro čtení
 
 
 
'#########################################
'getINIStrVal - když není hledaná hodnota nalezena, vrací defaultval,
'když pouze není nastavena, vrací prázdný řetezec.
'Tedy když zápis v ini je:
'hledhod
'    nebo
'hledhod=
'    nebo
'hledhod = ""
'> vrací vbNullString
'#########################################
 
 
Public Function getIniStrVal(ByVal filename As String, ByVal _
sectionname As String, ByVal keyname As String, Optional ByVal defaultval As _
String = vbNullString) As String
Dim returnlength As Long
Dim bufflen As Long
Dim skbuff As String
On Error GoTo errline
bufflen = buff_
skbuff = String$(buff_, vbNullChar)
againline:
returnlength = GetPrivateProfileString(sectionname, keyname, defaultval, _
skbuff, bufflen, filename)
If returnlength > 0 Then
    If returnlength > bufflen - 3 Then
        'když se načtená hodnota nevejde do skbuff, zvetši skbuff
        bufflen = bufflen * 2
        skbuff = String$(bufflen, vbNullChar)
        GoTo againline
    Else
        getIniStrVal = Left$(skbuff, returnlength)
    End If
Else
    getIniStrVal = vbNullString
End If
Exit Function
errline:
    getIniStrVal = vbNullString
    Err.Raise 1000, "getIniStrVal", "INI reading error"
End Function
 
 
'#####################################
'getIniNumVal - když není hledaná hodnota nalezena nebo nastavena nebo není integer, vrací defaultval
'#####################################
 
Public Function getIniNumVal(ByVal filename As String, ByVal _
sectionname As String, ByVal keyname As String, Optional ByVal defaultval As _
Long = defnum_) As Long
On Error GoTo errline
getIniNumVal = GetPrivateProfileInt(sectionname, keyname, defaultval, filename)
Exit Function
errline:
    Err.Raise 1000, "getIniNumVal", "INI reading error"
    getIniNumVal = defaultval
End Function
 
 
'#####################################
'addRemoveValue - když není nastavena setval, vymaže ceý řádek s keyname
'#####################################
 
Public Function addRemoveIniVal(ByVal filename As String, ByVal _
sectionname As String, ByVal keyname As String, Optional ByVal setval As _
String = vbNullString) As Boolean
Dim returnlength As Long
On Error GoTo errline
If Len(setval) > 0 Then
    returnlength = WritePrivateProfileString(sectionname, keyname, setval, filename)
Else
    returnlength = WritePrivateProfileString(sectionname, keyname, vbNullString, filename)
End If
If returnlength = 0 Then GoTo errline
addRemoveIniVal = True
Exit Function
errline:
    addRemoveIniVal = False
    Err.Raise 1000, "addRemoveIniVal", "INI writing error"
End Function
 
 
'##################################################
'readIniSection čte všechny hodnoty ze sekce section ini souboru filename
'vrací Boolean podle úspěšnosti čtení
'hodnoty ze sekce umístí do kolekce Ccoll se jmennými indexy
'rovnými názvům hodnot v ini souboru
'například:
'Řádek v ini: alfa=999
'přístup k hodnotě: Ccoll("alfa")
'##################################################
 
Public Function readIniSection(filename As String, section As String, ByRef Ccoll As Collection) As Boolean
Dim oneine As Variant, alllines As Variant, vvar As Variant
Dim skbuff As String
Dim bufflen As Long
Set Ccoll = New Collection
bufflen = buff_
skbuff = String$(buff_, vbNullChar)
On Error GoTo errline
'Následující volání je kvůli chybě http://support.microsoft.com/kb/198906/en-us?fr=1
GetPrivateProfileString "", "", "", skbuff, bufflen, filename
skbuff = String$(buff_, vbNullChar)
againline:
returnlength = GetPrivateProfileSection(section, skbuff, bufflen, filename)
If returnlength > 0 Then
    If returnlength > bufflen - 3 Then
        bufflen = bufflen * 2
        skbuff = String$(bufflen, vbNullChar)
        GoTo againline
    Else
        skbuff = Left$(skbuff, returnlength)
    End If
Else
    readIniSection = False
    Exit Function
End If
alllines = Split(skbuff, Chr$(0))
skbuff = vbNullString
For Each oneine In alllines
    If Trim(oneine) <> vbNullString Then
        vvar = Split(oneine, "=")
        If vvar(0) <> vbNullString Then Ccoll.Add CStr(vvar(1)), vvar(0)
    End If
Next
readIniSection = True
Exit Function
errline:
    skbuff = vbNullString
    readIniSection = False
    Err.Raise 1000, "readIniSection", "INI reading error"
End Function
 
'##################################################
'writeIniSection zapíše do ini souboru sekci section
'vrací Boolean podle úspěšnosti zápisu
'když sekce existuje, vymaže všechny její hodnoty
'když ne, vytvoří ji. Pokud je definováno pole iniarr, vloží do sekce jeho hodnoty
'iniarr = Array("jmenohodnoty1=hodnota1","jmenohodnoty2=hodnota2"...)
'POZOR - nerespektuje pořadí řádků, takže komentářové řádky
'uvozené středníkem nebudou korespondovat s hodnotami, které komentují
'pro zachování správných komentářů používejte addRemoveIniVal
'##################################################
 
Public Function writeIniSection(filename As String, sectionname As String, Optional iniarr As Variant) As Boolean
Dim strvals As String
Dim oneline As Variant
strvals = ""
On Error Resume Next
If UBound(iniarr) > 0 And False Then
    'díky false nastane jen při chybě, tedy když iniarr neexistuje
Else
    On Error GoTo 0
    For Each oneline In iniarr
       strvals = strvals & CStr(oneline) & Chr$(0)
    Next
End If
On Error GoTo errline
writeIniSection = WritePrivateProfileSection(sectionname, strvals, filename)
Exit Function
errline:
    writeIniSection = False
    Err.Raise 1000, "writeIniSection", "INI writing error"
End Function

Modul bas s uvedeným kódem ke stažení a importu.

Zdroje:

Příklad bez testu na velikost bufferu.
Téměř kompletní sady funkcí, ale se špatným testem.
Neoficiální definice zápisu ini souborů
Deklarace všech funkcí Win32 API  (nebo bez stahování)
GetPrivateProfile.../WritePrivateProfile... na webu Microsoftu
Inspirace - kniha o Access s kódy.
Použití registru Windows místo ini souborů.

{jcomments on}