Option Explicit
Option Compare Text

'********************************************************************
'*            Написано 12.03.2004 году (Team HomeWork)              *
'*                   e-mail: sne_pro@mail.ru                        *
'********************************************************************
'*                                                                  *
'*    Работа с ini файлами, аналогичная работе с реестром Windows   *
'*                                                                  *
'********************************************************************

Private Declare Function GetPrivateProfileInt Lib "kernel32.dll" Alias "GetPrivateProfileIntA" (ByVal strSection As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSection Lib "kernel32.dll" Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSectionNames Lib "kernel32.dll" Alias "GetPrivateProfileSectionNamesA" (ByVal lpszReturnBuffer As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'Private Declare Function GetPrivateProfileStruct Lib "kernel32.dll" Alias "GetPrivateProfileStructA" (ByVal lpszSection As String, ByVal lpszKey As String, lpStruct As Any, ByVal uSizeStruct As Long, ByVal szFile As String) As Long

Private Declare Function WritePrivateProfileSection Lib "kernel32.dll" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'Private Declare Function WritePrivateProfileStruct Lib "kernel32.dll" Alias "WritePrivateProfileStructA" (ByVal lpszSection As String, ByVal lpszKey As String, lpStruct As Any, ByVal uSizeStruct As Long, ByVal szFile As String) As Long

Private Declare Function WPPStrToDelKey Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal strSection As String, ByVal lpKeyName As String, ByVal lpString As Long, ByVal lplFileName As String) As Long
Private Declare Function WPPSToDelSec Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal strSection As String, ByVal lpKeyName As Long, ByVal lpString As Long, ByVal lplFileName As String) As Long

Private Declare Function DeleteFile Lib "kernel32.dll" Alias "eleteFileA" (ByVal lpFileName As String) As Long

Public Type gbHWIniExRetData
    sKeyName As String
    sValue   As String
End Type

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  SetValue
' Описание   :  Установка строкового значения
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sKeyName    - Имя ключа
'               sValue      - Значение
'--------------------------------------------------------------------------------
Public Sub SetValue(ByVal sFileName As String, _
                    ByVal sSectName As String, _
                    ByVal sKeyName As String, _
                    ByVal sValue As String)

    Call WritePrivateProfileString(VerDblSlash(sSectName, False), sKeyName, sValue, sFileName)
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  SetDWord
' Описание   :  Установка численного значения
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sKeyName    - Имя ключа
'               lValue      - Значение
'--------------------------------------------------------------------------------
Public Sub SetDWord(ByVal sFileName As String, _
                    ByVal sSectName As String, _
                    ByVal sKeyName As String, _
                    ByVal lValue As Long)

    Call WritePrivateProfileString(VerDblSlash(sSectName, False), sKeyName, Str$(lValue), sFileName)
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  SetKey
' Описание   :  Создание пустой секции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'--------------------------------------------------------------------------------
Public Sub SetKey(ByVal sFileName As String, _
                  ByVal sSectName As String)

    Call WritePrivateProfileSection(VerDblSlash(sSectName, False), "", sFileName)
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetValue
' Описание   :  Получение строкового значения
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sKeyName    - Имя ключа
'               sDefault    - Значение по умолчанию
'               lMaxSize    - Максимальная длинна строки
'--------------------------------------------------------------------------------
Public Function GetValue(ByVal sFileName As String, _
                         ByVal sSectName As String, _
                         ByVal sKeyName As String, _
                Optional ByVal sDefault As String = vbNullString, _
                Optional ByVal lMaxSize As Long = &H400& As String
    Dim slength As Long

    GetValue = String$(lMaxSize, &H0)
    slength = GetPrivateProfileString(VerDblSlash(sSectName, False), sKeyName, sDefault, GetValue, lMaxSize, sFileName)
    GetValue = Left$(GetValue, slength)
End Function

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetDword
' Описание   :  Получение числового значения
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sKeyName    - Имя ключа
'               lDefault    - Значение по умолчанию
'--------------------------------------------------------------------------------
Public Function GetDword(ByVal sFileName As String, _
                         ByVal sSectName As String, _
                         ByVal sKeyName As String, _
                Optional ByVal lDefault As Long = 0& As Long

    GetDword = GetPrivateProfileInt(VerDblSlash(sSectName, False), sKeyName, lDefault, sFileName)
End Function

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetKeys
' Описание   :  Получение секций (подсекций секции)
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName       - Имя ИНИ файла
'               sSectName       - Имя секции
'               strRetArray()   - Массив для возврата значений
'               lMaxSize        - Максимальный размер
'--------------------------------------------------------------------------------
Public Function GetKeys(ByVal sFileName As String, _
                        ByVal sSectName As String, _
                        ByRef strRetArray() As String, _
               Optional ByVal lMaxSize As Long = &H1000& As Long

    Dim sBuffer As String, tArray() As String, II As Long, lLen As Long, lSl As Long

    sBuffer = String$(lMaxSize, &H0)
    Erase strRetArray

    GetKeys = GetPrivateProfileSectionNames(sBuffer, lMaxSize, sFileName)

    If Not GetKeys > vbNull Then GetKeys = &HFFFF: Exit Function

    sBuffer = Left$(sBuffer, GetKeys - vbNull)
    tArray = Split(sBuffer, vbNullChar)

    sSectName = VerDblSlash(sSectName, True)
    lLen = Len(sSectName)

    If lLen = 0& Then
        strRetArray = tArray
        GetKeys = UBound(tArray)
    Else
        GetKeys = &HFFFF

        For II = 0 To UBound(tArray)
            If sSectName = Left$(tArray(II), lLen) Then
                lSl = InStr(lLen + 2, tArray(II), "\"
                sBuffer = Mid$(tArray(II), lLen + vbNull, IIf(lSl = 0&, Len(tArray(II)), lSl - lLen - vbNull))

                If Not (IsSubKeyExists(strRetArray, sBuffer)) Then
                    GetKeys = GetKeys + vbNull
                    ReDim Preserve strRetArray(GetKeys)

                    strRetArray(GetKeys) = sBuffer
                End If
            End If
        Next
    End If

    Erase tArray
End Function

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  GetKeyValues
' Описание   :  Получение имен и значений ключей в секции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName       - Имя ИНИ файла
'               sSectName       - Имя секции
'               strRetArray()   - Массив для возврата значений
'               lMaxSize        - Максимальный размер
'--------------------------------------------------------------------------------
Public Function GetKeyValues(ByVal sFileName As String, _
                             ByVal sSectName As String, _
                             ByRef strRetArray() As gbHWIniExRetData, _
                    Optional ByVal lMaxSize As Long = &H1000& As Long

    Dim sBuffer As String, tArray() As String, II As Long

    sBuffer = String$(lMaxSize, &H0)
    Erase strRetArray

    GetKeyValues = GetPrivateProfileSection(VerDblSlash(sSectName, False), sBuffer, lMaxSize, sFileName)

    If Not GetKeyValues > 1& Then GetKeyValues = &HFFFF: Exit Function

    sBuffer = Left$(sBuffer, GetKeyValues - vbNull)
    tArray = Split(sBuffer, vbNullChar)

    ReDim strRetArray(UBound(tArray))
    For II = 0 To UBound(tArray)
        strRetArray(II).sKeyName = Split(tArray(II), "="(0)
        strRetArray(II).sValue = Split(tArray(II), "="(1)
    Next

    Erase tArray
    GetKeyValues = UBound(strRetArray)
End Function

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  eleteValue
' Описание   :  Удаление ключа в секции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sKeyName    - Имя ключа
'--------------------------------------------------------------------------------
Public Sub DeleteValue(ByVal sFileName As String, _
                       ByVal sSectName As String, _
                       ByVal sKeyName As String)

    Call WPPStrToDelKey(VerDblSlash(sSectName, False), sKeyName, 0&, sFileName)
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  eleteKey
' Описание   :  Удаление одной секции, независимо от того содержатся ли в ней подсекции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               bWthSubKeys - Удалять-ли подсекции
'--------------------------------------------------------------------------------
Public Sub DeleteKey(ByVal sFileName As String, _
                     ByVal sSectName As String, _
            Optional ByVal bWthSubKeys As Boolean = True)
    Dim SubKeys() As String, i_r As Long

    If bWthSubKeys Then
        For i_r = 0 To GetKeys(sFileName, sSectName, SubKeys)
            Call DeleteKey(sFileName, VerDblSlash(sSectName, False) & "\" & (i_r), True)
        Next
    End If

    Call WPPSToDelSec(VerDblSlash(sSectName, False), 0&, 0&, sFileName)
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  CopyKeyValues
' Описание   :  Запись ключей и их значений в секции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName       - Имя ИНИ файла
'               sFromSection    - Имя секции с которой копируем
'               sToSection      - Имя секции в которую копируем
'               lMaxSize        - Максимальный размер данных
'--------------------------------------------------------------------------------
Public Sub CopyKeyValues(ByVal sFileName As String, _
                         ByVal sFromSection As String, _
                         ByVal sToSection As String, _
                Optional ByVal lMaxSize As Long = &H1000&
    Dim lLen As Long, sBuffer As String

    sBuffer = sBuffer = String$(lMaxSize, &H0)
    lLen = GetPrivateProfileSection(VerDblSlash(sFromSection, False), sBuffer, lMaxSize, sFileName)

    If Not lLen > 1& Then Exit Sub
    sBuffer = Left$(sBuffer, lLen)

    Call WritePrivateProfileSection(sToSection, sBuffer, sFileName)
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Пара функций без АПИ, но очень нужных в работе §§§§§§§§§§§§§§§§§§§§§§§§§§

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  RenameKey
' Описание   :  Переименование секции
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя ИНИ файла
'               sSectName   - Имя секции
'               sNewSName   - Новое имя секции
'--------------------------------------------------------------------------------
Public Sub RenameKey(ByVal sFileName As String, _
                     ByVal sSectName As String, _
                     ByVal sNewSName As String)
    Dim nf As Long, sBuffer As String, slArray() As String
    nf = FreeFile

    If FileLen(sFileName) = 0& Then Exit Sub

    Open sFileName For Binary Access Read Lock Write As nf
        sBuffer = String$(LOF(nf), 0&
        Get nf, 1, sBuffer
    Close nf

    slArray = Split(sBuffer, vbCrLf)
    For nf = 0 To UBound(slArray)
        If slArray(nf) = Chr$(&H5B) & sSectName & Chr$(&H5D) Then slArray(nf) = Chr$(&H5B) & sNewSName & Chr$(&H5D)
    Next
    sBuffer = Join(slArray, vbCrLf)

    nf = FreeFile
    Open sFileName For Binary Access Write Lock Read As nf
        Put nf, 1, sBuffer
    Close nf

    Erase slArray
End Sub

'--------------------------------------------------------------------------------
' Проект     :  OfflineClient
' Процедура  :  NormFile
' Описание   :  Привидение ини файла в "читабельный" вид
' Кем создан :  SNE
' Дата-Время :  08.11.2004-17:44:28
'
' Параметры  :  sFileName   - Имя файла
'--------------------------------------------------------------------------------
Public Sub NormFile(sFileName As String)
    Dim nf As Long, ub As Long, sBuffer As String, slArray() As String, sOutArray() As String
    nf = FreeFile

    If FileLen(sFileName) = 0& Then Exit Sub

    Open sFileName For Binary Access Read Lock Write As nf
        sBuffer = String$(LOF(nf), 0&
        Get nf, 1, sBuffer
    Close nf

    slArray = Split(sBuffer, vbCrLf)
    ub = &HFFFF

    For nf = 0 To UBound(slArray)
        If Len(slArray(nf)) Then
            ub = ub + IIf(Left$(slArray(nf), vbNull) = Chr$(&H5B), 2, vbNull)

            ReDim Preserve sOutArray(ub)
            sOutArray(ub) = slArray(nf)
        End If
    Next
    sBuffer = Join(sOutArray, vbCrLf)
    Call DeleteFile(sFileName)

    nf = FreeFile
    Open sFileName For Binary Access Write Lock Read As nf
        Put nf, 1, sBuffer
    Close nf
End Sub

' §§§§§§§§§§§§§§§§§§§§§§§§§§ Вспомогательное добро §§§§§§§§§§§§§§§§§§§§§§§§§§

    ' Добавление/Удаление слэша на конце
Private Function VerDblSlash(ByVal sInSection As String, _
                    Optional ByVal bFlag As Boolean = False) As String

    If Len(sInSection) = 0& Then Exit Function

    If bFlag Then
        VerDblSlash = IIf(Right$(sInSection, vbNull) = "\", sInSection, sInSection & "\"
    Else
        VerDblSlash = IIf(Right$(sInSection, vbNull) = "\", Left$(sInSection, Len(sInSection) - vbNull), sInSection)
    End If
End Function

Private Function IsSubKeyExists(ByRef arr() As String, _
                                ByRef s As String) As Boolean

    Dim i As Long

    On Error GoTo err_h

    For i = 0& To UBound(arr)

        If (arr(i) = s) Then

            IsSubKeyExists = True
            Exit For

        End If

    Next

err_h:
End Function