-=Белый Медведь=-
Профиль
Группа: Комодератор
Сообщений: 4054
Регистрация: 24.4.2006
Где: г. Тверь
Репутация: 11
Всего: 109
|
Выношу на всеобщее обозрение написанный вчера вечером класс для работы с ini-файлами. Использовал пример Дена Эппельмана (Dann Appleman). Прошу высказывать свои суждения, замечания? Думаю, что из коментариев всё будет понятно, хотя в них могут быть ошибки. Коментарии писал поздно ночью... ;) Алгоритм работы с классом такой: 1. Создаём экземпляр объекта. 2. Указываем имя ini-файла (свойство FileName) 3. Начинаем работать: создаём секции, ключи, читаем/пишм их значения и т.п... | Код |
Option Explicit
Option Base 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ЛОКАЛЬНЫЕ ФУНКЦИИ API-функции
' Взято из примера Dann Appleman
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' Aliases for profile strings
'
#If Win32 Then
' This first line is the declaration from win32api.txt
' Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpfilename As String) As Long
Private Declare Function GetPrivateProfileStringByKeyName& Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName$, ByVal lpszKey$, ByVal lpszDefault$, ByVal lpszReturnBuffer$, ByVal cchReturnBuffer&, ByVal lpszFile$)
Private Declare Function GetPrivateProfileStringKeys& Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName$, ByVal lpszKey&, ByVal lpszDefault$, ByVal lpszReturnBuffer$, ByVal cchReturnBuffer&, ByVal lpszFile$)
Private Declare Function GetPrivateProfileStringSections& Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName&, ByVal lpszKey&, ByVal lpszDefault$, ByVal lpszReturnBuffer$, ByVal cchReturnBuffer&, ByVal lpszFile$)
' This first line is the declaration from win32api.txt
' Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, lpString As Any, ByVal lplFileName As String) As Long
Private Declare Function WritePrivateProfileStringByKeyName& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String)
Private Declare Function WritePrivateProfileStringToDeleteKey& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Long, ByVal lplFileName As String)
Private Declare Function WritePrivateProfileStringToDeleteSection& Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Long, ByVal lpString As Long, ByVal lplFileName As String)
Private Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpfilename As String) As Long
#Else
' These are 16 bit declarations based on API16.TXT - some of the parameter names may be different
Private Declare Function GetPrivateProfileStringByKeyName% Lib "Kernel" Alias "GetPrivateProfileString" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpfilename$)
Private Declare Function WritePrivateProfileStringByKeyName% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString$, ByVal lplFileName$)
Private Declare Function GetPrivateProfileStringKeys% Lib "Kernel" Alias "GetPrivateProfileString" (ByVal lpApplicationName$, ByVal lpKeyName&, ByVal lpDefault$, ByVal lpReturnedString$, ByVal nSize%, ByVal lpfilename$)
Private Declare Function WritePrivateProfileStringToDeleteKey% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal lpApplicationName$, ByVal lpKeyName$, ByVal lpString&, ByVal lplFileName$)
Private Declare Function WritePrivateProfileStringToDeleteSection% Lib "Kernel" Alias "WritePrivateProfileString" (ByVal lpApplicationName$, ByVal lpKeyName&, ByVal lpString&, ByVal lplFileName$)
#End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ЛОКАЛЬНЫЕ ПЕРЕМЕННЫЕ
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private intError As Integer ' ошибка времени исполнения
' 255 - ошибка при работе с файловой системой...
Private strFileName As String ' Имя файла
Private lngBufferSize As Long ' Размер буфера
'********************************************************************
'*
'* Процедура инициализации класса
'*
'********************************************************************
Private Sub Class_Initialize()
strFileName = ""
lngBufferSize = 0
End Sub
'********************************************************************
'*
'* Свойство : FileName
'* Описание : содержит имя ini-файла
'*
'********************************************************************
Public Property Let FileName(ByVal MyValue As String)
strFileName = ""
lngBufferSize = 0
If IsFileExists(MyValue) Then
strFileName = MyValue
lngBufferSize = FileSize(strFileName)
End If
End Property
Public Property Get FileName() As String
FileName = strFileName
End Property
'********************************************************************
'*
'* Свойство : Error
'* Описание : содержит код ошибки времени исполнения...
'*
'********************************************************************
Public Property Let Error(ByVal MyValue As Integer)
intError = MyValue
End Property
Public Property Get Error() As Integer
Error = intError
End Property
'********************************************************************
'*
'* Функция : GetSectionNames
'* Описание : Возвращает количество секций в файле и список, содержащий имена секций
'* Вход : SectionNames - имена секции (любое значение...)
'* Выход : GetSectionNames - число секций в файле
'* SectionNames - имена всех секций, разделённых символом chr(0)
'********************************************************************
Public Function GetSectionNames(ByRef SectionNames As String) As Integer
Dim characters, N, i As Long
GetSectionNames = 0
SectionNames = ""
' Если длина буфера нулевая, то выходим...
If lngBufferSize = 0 Then Exit Function
' Резервируем буфер...
SectionNames = String$(lngBufferSize, Chr(0))
' Выделяем имена секций файла
characters = GetPrivateProfileStringSections(0, 0, "", SectionNames, lngBufferSize - 1, strFileName)
For i = characters To 1 Step -1
If Mid(SectionNames, i, 1) <> Chr(0) Then Exit For
Next i
SectionNames = Mid(SectionNames, 1, i)
' Вычисляем количество секций в файле...
N = 0
If characters > 0 Then
For i = 1 To characters
If Mid(SectionNames, i, 1) = Chr(0) Then N = N + 1
Next i
GetSectionNames = N + 1
End If
End Function
'********************************************************************
'*
'* Функция : GetKeyNames
'* Описание : Возвращает количество ключей секции ini-файла и список, содержащий имена ключей
'* Вход : SectionNames - имя секции
'* KeyNames - имена ключей (любое значение...)
'* Выход : GetKeyNames - число ключей в секции
'* KeyNames - имена всех ключей, разделённых символом chr(0)
'********************************************************************
Public Function GetKeyNames(ByVal SectionNames As String, ByRef KeyNames As String) As Integer
Dim characters, N, i As Long
GetKeyNames = 0
KeyNames = ""
' Если длина буфера нулевая, то выходим...
If lngBufferSize = 0 Then Exit Function
' Резервируем буфер...
KeyNames = String$(lngBufferSize, Chr(0))
' Выделяем имена ключей в секции
characters = GetPrivateProfileStringKeys(SectionNames, 0, "", KeyNames, lngBufferSize - 1, strFileName)
For i = characters To 1 Step -1
If Mid(KeyNames, i, 1) <> Chr(0) Then Exit For
Next i
KeyNames = Mid(KeyNames, 1, i)
' Вычисляем количество ключей в секции...
N = 0
If characters > 0 Then
For i = 1 To characters
If Mid(KeyNames, i, 1) = Chr(0) Then N = N + 1
Next i
GetKeyNames = N + 1
End If
End Function
'********************************************************************
'*
'* Функция : WriteKey
'* Описание : Записывает ключ в секцию в указанном файл
'* Если ключа или секции до этого не было, то они предварительно создаются...
'* Вход : SectionNames - имя секции
'* KeyName - имя ключа
'* KeyValue - значение ключа
'* Выход : WriteKey - 0, если удалить ключ не удалось
'********************************************************************
Public Function WriteKey(ByVal SectionName As String, ByVal KeyName As String, ByVal KeyValue As String) As Long
If Len(KeyValue) = 0 Then KeyValue = " "
WriteKey = WritePrivateProfileStringByKeyName(SectionName, KeyName, KeyValue, strFileName)
End Function
'********************************************************************
'*
'* Функция : DeleteKey
'* Описание : Удаляет ключ из указанной секции
'* Вход : SectionName - имя секции
'* KeyName - имя ключа
'* Выход : DeleteKey - 0, если удалить ключ не удалось
'********************************************************************
Public Function DeleteKey(ByVal SectionName As String, ByVal KeyName As String) As Long
DeleteKey = WritePrivateProfileStringToDeleteKey(SectionName, KeyName, 0, strFileName)
End Function
'********************************************************************
'*
'* Функция : WriteSection
'* Описание : Записывает секцию в указанный файл
'* Вход : SectionNames - имя секции
'* Выход : WriteSection - 0, если удалить ключ не удалось
'********************************************************************
Public Function WriteSection(ByVal SectionName As String) As Long
WriteSection = WritePrivateProfileSection(SectionName, "", strFileName)
End Function
'********************************************************************
'*
'* Функция : DeleteSection
'* Описание : Удаляет секцию из указанного файла
'* Вход : SectionNames - имя секции
'* Выход : DeleteSection - 0, если удалить ключ не удалось
'********************************************************************
Public Function DeleteSection(ByVal SectionName As String) As Long
DeleteSection = WritePrivateProfileStringToDeleteSection(SectionName, 0&, 0&, strFileName)
End Function
'********************************************************************
'*
'* Функция : GetKeyValue
'* Описание : Возвращает строковое значение ключа секции какого-то файла
'* Вход : section - имя секции
'* key - имя ключа
'* Выход : GetKeyValue - значение ключа секции
'********************************************************************
Public Function GetKeyValue(ByVal section As String, ByVal key As String) As String
Dim KeyValue As String
Dim characters As Long
GetKeyValue = ""
KeyValue = String$(lngBufferSize, Chr(0))
characters = GetPrivateProfileStringByKeyName(section, key, "", KeyValue, lngBufferSize - 1, strFileName)
If characters > 0 Then
GetKeyValue = Left(KeyValue, characters)
End If
End Function
'********************************************************************
'*
'* Функция : KeyExists
'* Описание : Определяет, существует ли ключ или нет
'* Вход : section - имя секции
'* key - имя ключа
'* Выход : KeyExists - true, если ключ сушествует, и false в противном случае.
'********************************************************************
Public Function KeyExists(ByVal section As String, ByVal key As String) As Boolean
Dim strS As String
Dim N As Long
KeyExists = False
N = GetKeyNames(section, strS)
If N = 0 Then Exit Function
KeyExists = blnTestString(strS, "(^|\x00)+" & key & "($|\x00)+")
End Function
'********************************************************************
'*
'* Функция : SectionExists
'* Описание : Определяет, существует ли секция или нет
'* Вход : section - имя секции
'* Выход : SectionExists - true, если ключ сушествует, и false в противном случае.
'********************************************************************
Public Function SectionExists(ByVal section As String) As Boolean
Dim strS As String
Dim N As Long
SectionExists = False
N = GetSectionNames(strS)
If N = 0 Then Exit Function
SectionExists = blnTestString(strS, "(^|\x00)+" & section & "($|\x00)+")
End Function
'********************************************************************
'*
'* Функция : blnTestString (приватная)
'* Описание : Определяет соответствует ли строка шаблону
'* Вход : strString - строка
'* strPath - шаблон (регулярное выражение)
'* Выход : true - соответствует шаблону; false - не соответствует шаблону
'*
'********************************************************************
Private Function blnTestString(ByVal strString As String, ByVal strPath As String) As Boolean
Dim RegEx As Object
' Создаём экземпляр объекта RegExp
Set RegEx = CreateObject("VBScript.RegExp")
' Настраиваем режимы работы регулярного выражения
RegEx.MultiLine = True
RegEx.Global = True
RegEx.IgnoreCase = True
RegEx.Pattern = strPath
' Тестируем строку на соответствие шаблону
blnTestString = RegEx.Test(strString)
' Уничтожаем экземпляр объекта RegExp
Set RegEx = Nothing
End Function
'********************************************************************
'*
'* Функция : IsFileExists
'* Описание : определяет существует файл или нет
'* Вход : FName - имя файла
'* Выход : true - файл существует, false - в противном случае
'* если во время работы функции произошла ошибка, то
'* intError = 255
'********************************************************************
Private Function IsFileExists(ByVal FName As String) As Boolean
Dim fso As Object
On Error GoTo MyError
intError = 0
IsFileExists = False
Set fso = CreateObject("Scripting.FileSystemObject")
IsFileExists = fso.FileExists(FName)
Set fso = Nothing
Exit Function
MyError:
intError = 255
End Function
'********************************************************************
'*
'* Функция : FileSize
'* Описание : определяет размер файла в байтах
'* Вход : FName - имя файла
'* Выход : размер файла в байтах
'* если во время работы функции произошла ошибка, то
'* intError = 255
'********************************************************************
Private Function FileSize(ByVal FName As String) As Long
Dim fso, f As Object
On Error GoTo MyError
intError = 0
FileSize = 0
If IsFileExists(FName) Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(FName)
FileSize = f.Size
Set f = Nothing
Set fso = Nothing
End If
Exit Function
MyError:
intError = 255
End Function
|
А вот и сам файл класса...
Присоединённый файл ( Кол-во скачиваний: 18 )
VBIniClass.cls 15,75 Kb--------------------
Программистами не рождаются, - это родовая травма...   |
Класс для работы с ini-файлами, с использованием API 
Загрузка ...
