Урок 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 | |
Коментарии (2)