Урок 4. Работа с файлами. Диалоги открытия файла/папки. В этом уроке расскажу о том, как в Access'e (VBA) можно работать с файлами. Функции открытия диалоговых окон принадлежат Сергею Грибанову, я их только немного модифицировал. Итак, для работы с файлами нам как минимум необходимо знать где эти файлы находяться (или должны находиться). Можно конечно заставить пользователя "ручками" печатать в каком-либо поле путь и имя файла... Но это, сами понимаете, далеко от совершенства. Поэтому для начала нам нужны 2 функции, которые будут возвращать указанные пользователем папки или файлы, причем в родном и приятном юзерскому глазу виндовом интерфейсе :-) Ну и потому будем использовать эти самые виндовые функции. Но для создания этих функций нам много что понадобиться, поэтому займемся делом. Нам будут полезны функции, проверяющие наличие файла или папки на диске. Для этого нам нужно будет использовать функцию Dir. Функция Dir. Возвращает значение типа String, представляющее имя файла, каталога или папки, которое удовлетворяет указанному шаблону имени файла, набору атрибутов файла или метке тома на диске. Dir[(путь[, атрибуты])] путь - Необязательный. Строковое выражение, указывающее имя файла; может содержать имя каталога или папки и диска. Если путь не найден, возвращается пустая строка (""). атрибуты - Необязательный. Константа или числовое выражение, описывающее атрибуты файла. Если этот аргумент опущен, возвращаются все файлы, имена которых удовлетворяют аргументу путь. Ниже приведены допустимые значения аргумента атрибуты Константа | Значение | Описание | vbNormal | 0 | Обычный | vbHidden | 2 | Скрытый | vbSystem | 4 | Системный | vbVolume | 8 | Метка тома; если указана, все остальные атрибуты игнорируются. | vbDirectory | 16 | Каталог или папка. | Данные константы определяются в языке Visual Basic для приложений. Это означает, что их имена можно использовать в любом месте кода вместо фактических значений. Функция Dir поддерживает использование подстановочных знаков для нескольких символов (*) и для одиночного символа (?) для указания нескольких файлов. При первом вызове функции Dir необходимо указать путь, в противном случае возникает ошибка. Если указаны атрибуты файла, наличие аргумента путь является обязательным. Функция Dir возвращает первое имя файла, имя которого удовлетворяет аргументу путь. Для получения остальных файлов, имена которых удовлетворяют указанному пути, следует повторно вызвать функцию Dir без аргументов. Если файлов, имена которых удовлетворяют указанному пути, не осталось, возвращается пустая строка (""). При следующем после возврата пустой строки вызове функции необходимо указать аргумент путь; в противном случае возникает ошибка. Изменить значение аргумента путь можно в любой момент, не дожидаясь, пока закончатся файлы, имена которых удовлетворяют текущему пути. Рекурсивный вызов функции Dir запрещен. Вызов функции Dir с атрибутом vbDirectory не приводит к последовательному возврату подкаталогов. Поскольку имена файлов возвращаются в произвольном порядке, их можно сохранить в массиве, а затем отсортировать этот массив. Функция, проверяющая наличие файла на диске: Function FileUtils_IsFilePresent(ByVal strFileName As String) As Boolean '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Функция возвращает TRUE, если файл strFileName существует '---------------------------------------------------------- Dim strTmp As String 'Временная переменная 'Для начала предположим что файл не существует FileUtils_IsFilePresent = False 'При возникновении ошибки - переход на следующую строчку функции On Error Resume Next 'Вызываем функцию Dir для переданного имени файла strTmp = Dir(strFileName) 'Если произошла ошибка (т.е. файла нет) - выходим из функции If Err <> 0 Then Exit Function 'Если временная переменная не пустая - ф-ия возвращает TRUE If strTmp <> Empty Then FileUtils_IsFilePresent = True End Function | Функция, проверяющая наличие папки на диске: Function FileUtils_IsFolderPresent(ByVal strFileName As String) As Boolean '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Функция возвращает TRUE, если папка strFileName существует '---------------------------------------------------------- Dim strTmp As String 'Временная переменная 'Для начала предположим что папки не существует FileUtils_IsFolderPresent = False 'При возникновении ошибки - переход на следующую строчку функции On Error Resume Next 'Вызываем функцию Dir для переданного имени папки с папаметром vbDirectory strTmp = Dir(strFileName, vbDirectory) 'Если произошла ошибка (т.е. папки нет) - выходим из функции If Err <> 0 Then Exit Function 'Если временная переменная не пустая - ф-ия возвращает TRUE If strTmp <> Empty Then FileUtils_IsFolderPresent = True End Function | Далее нам потребуется описать некоторые пользовательские типы данных, константы и API-функции. Не буду подробно разбирать зачем что нужно - это уже больше технология API. Просто вставим в начало модуля следующий текст: Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (ByRef lpFolderOp As BROWSEINFO) As Long Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal lPIDL As Long, ByRef pszPath As Byte) As Boolean Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWnd As Long, ByVal nFolder As Integer, ByRef lPIDL As ITEMIDLIST) As Long Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean Type SHITEMID cb As Integer abID(1) As Byte End Type Type ITEMIDLIST mkid As SHITEMID End Type Type BROWSEINFO hwndOwner As Long pidlRoot As ITEMIDLIST pszDisplayName As String lpszTitle As String ulFlags As Integer lpfn As Long lParam As Long iImage As Integer End Type Type FileUtils_OPENFILENAME ' Отбор строк, используемых в фильтрах диалоговом окне "Открытие". ' Для создания фильтров вызывает FileUtils_CreateFilterString(). ' Значение по умолчанию = Все файлы, *.* strFilter As String ' Исходный фильтр. ' Значение по умолчанию = 1. lngFilterIndex As Long ' Исходный каталог, для которого открывается диалоговое окно. ' Значение по умолчанию = текущий рабочий каталог. strInitialDir As String ' Исходное имя файлов, выводящихся в диалоговом окне. ' Значение по умолчанию = "". strInitialFile As String strDialogTitle As String ' Стандартное расширение имени файла, если не указано пользователем. ' Значение по умолчанию = системные значения (Открыть, Сохранить). strDefaultExtension As String ' Используемые флаги (см. список констант). ' Значение по умолчанию = отсутствие флагов. lngFlags As Long ' Полный путь к выбранному файлу. Если пользователь указал ' несуществующий файл, по команде "Открыть" возвращается ' только текст из поля "Имя файла". strFullPathReturned As String ' Имя выбранного файла. strFileNameReturned As String ' Позиция в полном пути (strFullPathReturned), с которой ' начинается имя файла (strFileNameReturned). intFileOffset As Integer ' Позиция в полном пути (strFullPathReturned), с которой ' начинается расширение имени файла. intFileExtension As Integer End Type Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As Long nMaxCustrFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustrData As Long lpfnHook As Long lpTemplateName As Long End Type Const BIF_RETURNONLYFSDIRS = 1 Const CSIDL_DRIVES = 17 Const ALLFILES = "Все файлы" | Напишем функцию составления критерия для имен файлов (это такое поле со списком в котором перечисляется какие типы файлов с каким расширением показывать в окне открытия файлов). Дело в том, что для использования в API-функции такого критерия необходимо, чтобы строчка критерия была следующего вида: ...НазваниеКритерия{НулевойСимвол}Критерий..., т.е. для того, чтобы в диалоге открытия файла была возможность выбирать, допустим, только файлы баз данных и только текстовые файлы эта строка должна выглядеть так: Базы данных MS Access{НулевойСимвол}*.mdb{НулевойСимвол}Текстовые файлы{НулевойСимвол}*.txt Будем передавать в функцию массив строчек, а на выходе получать правильную строчку для критерия: Function FileUtils_CreateFilterString(varFilt() As Variant) As String '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Создает из переданных аргументов строку фильтра. ' Возвращает "", если аргументы не переданы. ' Ожидается четное число аргументов (имя фильтра, расширение). ' Если передано нечетное число аргументов, добавляется "*.*". '---------------------------------------------------------- On Error GoTo Err_FileUtils_CreateFilterString Dim strFilter As String Dim intRet As Integer Dim intNum As Integer intNum = UBound(varFilt) If (intNum <> -1) Then For intRet = 0 To intNum strFilter = strFilter & varFilt(intRet) & vbNullChar Next If intNum Mod 2 = 0 Then strFilter = strFilter & "*.*" & vbNullChar End If strFilter = strFilter & vbNullChar Else strFilter = "" End If FileUtils_CreateFilterString = strFilter Exit_FileUtils_CreateFilterString: Exit Function Err_FileUtils_CreateFilterString: MsgBox Err.Description Resume Exit_FileUtils_CreateFilterString End Function | Напишем 2 процедуры перехода между структурами OPENFILENAME (с этой структурой работают API функции, но она не совсем удобна для работы в VB) и FileUtils_OPENFILENAME (более удобная для работы структура). Sub FileUtils_MSAOF_to_OF(msaof As FileUtils_OPENFILENAME, of As OPENFILENAME) '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Данная процедура осуществляет переход от удобной ' структуры MSAccess к структуре win32. '---------------------------------------------------------- On Error GoTo Err_FileUtils_MSAOF_to_OF Dim strFile As String * 512 ' Инициализирует некоторые компоненты структуры. of.hwndOwner = Application.hWndAccessApp of.hInstance = 0 of.lpstrCustomFilter = 0 of.nMaxCustrFilter = 0 of.lpfnHook = 0 of.lpTemplateName = 0 of.lCustrData = 0 ReDim varArr(0) As Variant varArr(0) = ALLFILES If msaof.strFilter = "" Then of.lpstrFilter = FileUtils_CreateFilterString(varArr()) Else of.lpstrFilter = msaof.strFilter End If of.nFilterIndex = msaof.lngFilterIndex of.lpstrFile = msaof.strInitialFile & String$(512 - Len(msaof.strInitialFile), 0) of.nMaxFile = 511 of.lpstrFileTitle = String$(512, 0) of.nMaxFileTitle = 511 of.lpstrTitle = msaof.strDialogTitle of.lpstrInitialDir = msaof.strInitialDir of.lpstrDefExt = msaof.strDefaultExtension of.Flags = msaof.lngFlags of.lStructSize = Len(of) Exit_FileUtils_MSAOF_to_OF: Exit Sub Err_FileUtils_MSAOF_to_OF: MsgBox Err.Description Resume Exit_FileUtils_MSAOF_to_OF End Sub | Sub FileUtils_OF_to_MSAOF(of As OPENFILENAME, msaof As FileUtils_OPENFILENAME) '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Данная процедура осуществляет переход от структуры win32 ' к удобной структуре MSAccess. '---------------------------------------------------------- On Error GoTo Err_FileUtils_OF_to_MSAOF msaof.strFullPathReturned = Left$(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1) msaof.strFileNameReturned = of.lpstrFileTitle msaof.intFileOffset = of.nFileOffset msaof.intFileExtension = of.nFileExtension Exit_FileUtils_OF_to_MSAOF: Exit Sub Err_FileUtils_OF_to_MSAOF: MsgBox Err.Description Resume Exit_FileUtils_OF_to_MSAOF End Sub | Напишем функцию, вызывающую нужную нам API-функцию. Передадим на ее вход переменную стуктуры FileUtils_OPENFILENAME, которая после завершения работы функции будет содержать нужную нам информацию в том случае, если пользователь выбрал какой-либо файл в диалоговом окне. Function FileUtils_GetOpenFileName(msaof As FileUtils_OPENFILENAME) As Integer '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Открывает диалоговое окно "Открытие". '---------------------------------------------------------- On Error GoTo Err_FileUtils_GetOpenFileName Dim of As OPENFILENAME Dim intRet As Integer 'Преобразовываем структуру FileUtils_MSAOF_to_OF msaof, of 'Вызываем API-функцию диалога открытия файла intRet = GetOpenFileName(of) 'Если был выбран какой-то файл... If intRet Then 'Преобразовываем структуру обратно FileUtils_OF_to_MSAOF of, msaof End If FileUtils_GetOpenFileName = intRet Exit_FileUtils_GetOpenFileName: Exit Function Err_FileUtils_GetOpenFileName: MsgBox Err.Description Resume Exit_FileUtils_GetOpenFileName End Function | А вот теперь собственно функция диалога открытия файла: Function FileUtils_GetFileName(Optional ByVal Title As String = "Выберите файл:", Optional varInitialDir As Variant, Optional varInitialFile As Variant, Optional varFilter As Variant) As String '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Диалог открытия файла ' Title - Текст заголовка окна диалога ' varInitialDir - Исходный каталог, для которого открывается диалоговое окно. ' Значение по умолчанию = текущий рабочий каталог. ' varInitialFile - Исходное имя файлов, выводящихся в диалоговом окне. ' varFilter - Исходный фильтр, в котором параметры должны быть разделены точкой с запятой ' Примеры вызова функции: ' ? FileUtils_GetFileName() ' ? FileUtils_GetFileName("Открыть файл","D:") ' ? FileUtils_GetFileName(,,"D:MyBase.mdb") ' ? FileUtils_GetFileName(,,,"Базы данных;*.mdb;Рисунки BMP;*.bmp") '---------------------------------------------------------- On Error GoTo Err_FileUtils_GetFileName Dim msaof As FileUtils_OPENFILENAME Dim intRet As Integer Dim strRet As String Dim varArray() As Variant Dim strTmp As String Dim i As Long Dim lngBound As Long ReDim varArray(0) lngBound = -1 msaof.strDialogTitle = Title If Not IsMissing(varInitialDir) Then If FileUtils_IsFolderPresent(CStr(varInitialDir)) = True Then msaof.strInitialDir = CStr(varInitialDir) End If End If If Not IsMissing(varInitialFile) Then If FileUtils_IsFilePresent(CStr(varInitialFile)) = True Then msaof.strInitialFile = CStr(varInitialFile) End If End If If Not IsMissing(varFilter) Then For i = 1 To Len(varFilter) If Mid(varFilter, i, 1) = ";" Then lngBound = lngBound + 1 ReDim Preserve varArray(lngBound) varArray(lngBound) = strTmp strTmp = "" Else strTmp = strTmp & Mid(varFilter, i, 1) End If Next i If strTmp <> "" Then ReDim Preserve varArray(UBound(varArray) + 1) varArray(UBound(varArray)) = strTmp End If msaof.strFilter = FileUtils_CreateFilterString(varArray()) End If intRet = FileUtils_GetOpenFileName(msaof) If intRet Then strRet = msaof.strFullPathReturned End If FileUtils_GetFileName = strRet Exit_FileUtils_GetFileName: Exit Function Err_FileUtils_GetFileName: MsgBox Err.Description Resume Exit_FileUtils_GetFileName End Function | ... и функция диалога открытия папки: Function FileUtils_GetFolderName(Optional ByVal Title As String = "Выберите папку:", Optional ByVal hWnd As Variant) As String '© NSA Programmer, 2001. http://www.msaccess.ru ~ E-mail:
Этот e-mail защищен от спам-ботов. Для его просмотра в вашем браузере должна быть включена поддержка Java-script
~ ICQ: 7349882 '---------------------------------------------------------- ' Диалог открытия папки ' Title - Текст заголовка окна диалога ' hWnd - дискриптор родительского окна. ' Примеры вызова функции: ' ? FileUtils_GetFolderName() ' ? FileUtils_GetFolderName("Папка",Me.hWnd) '---------------------------------------------------------- On Error GoTo Err_FileUtils_GetFolderName If IsMissing(hWnd) Then hWnd = hWndAccessApp End If Dim acFolder As BROWSEINFO Dim acPath(0 To 259) As Byte Dim s As String Dim i As Long With acFolder .hwndOwner = hWnd .lpszTitle = Title .ulFlags = BIF_RETURNONLYFSDIRS Call SHGetSpecialFolderLocation(Application.hWndAccessApp, CSIDL_DRIVES, .pidlRoot) End With Call SHGetPathFromIDList(SHBrowseForFolder(acFolder), acPath(0)) For i = 0 To 259 Step 1 If acPath(i) <> 0 Then s = s & Chr(acPath(i)) Next i FileUtils_GetFolderName = s Exit_FileUtils_GetFolderName: Exit Function Err_FileUtils_GetFolderName: MsgBox Err.Description Resume Exit_FileUtils_GetFolderName End Function | |