|
Private Sub butSelectFile_Click()
' Включите библитеку libDialogFiles
Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub
'#Const constOffice2000 = 0 ' Для Microsoft Office 97
#Const constOffice2000 = 1 ' Для Microsoft Office 2000
Private Declare Function funOfficeGetFile _
Lib "msaccess.exe" Alias "#56" _
(gfni As accOfficeGetFileNameInfo, fOpen As Integer) As Long
' OfficeGetFileName flags
Public Const flagNoChangeDir = &H2 ' Не меняет каталог пользователя
Public Const flagDirectoryOnly = &H20 ' Открывает только папку
Public Type accOfficeGetFileNameInfo
hwndOwner As Long
strAppName As String * 255
strDlgTitle As String * 255
strOpenTitle As String * 255
strFile As String * 4096
strInitialDir As String * 255
strFilter As String * 255
lngFilterIndex As Long
lngView As Long
lngFlags As Long
End Type
'Функция открытия файла
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
FILENAME As OPENFILENAME) As Boolean
'Функция сохранения файла
Declare Function apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" ( _
FILENAME As OPENFILENAME) As Boolean
'Структура файла, описание дано ниже
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustFilter 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
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
'Флажки для параметра OPENFILENAME.Flags
' (например, OFN_FILEMUSTEXIST Or OFN_READONLY)
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0
' Получение папки для программы
Public Function fOfficeGetFileName( _
gfni As accOfficeGetFileNameInfo, _
ByVal fOpen As Integer) As Long
Dim lngReturn As Long
With gfni
.strAppName = RTrim$(.strAppName) & vbNullChar
.strDlgTitle = RTrim$(.strDlgTitle) & vbNullChar
.strOpenTitle = RTrim$(.strOpenTitle) & vbNullChar
.strFile = RTrim$(.strFile) & vbNullChar
.strInitialDir = RTrim$(.strInitialDir) & vbNullChar
.lngFilterIndex = 1
.strFilter = RTrim$(.strFilter) & vbNullChar '"Все файлы (*.*)" & vbNullChar
lngReturn = funOfficeGetFile(gfni, fOpen)
.strAppName = fTrimNull(.strAppName)
.strDlgTitle = fTrimNull(.strDlgTitle)
.strOpenTitle = fTrimNull(.strOpenTitle)
.strFile = fTrimNull(.strFile)
.strInitialDir = fTrimNull(.strInitialDir)
.strFilter = fTrimNull(.strFilter)
End With
fOfficeGetFileName = lngReturn
End Function
'Обрезка данных
Private Function fTrimNull(strVal As String) As String
Dim lngPos As Long
lngPos = InStr(1, strVal, vbNullChar)
Select Case lngPos
Case Is > 1: fTrimNull = Left$(strVal, lngPos - 1)
Case 0: fTrimNull = strVal
Case 1: fTrimNull = vbNullString
End Select
End Function
'==============================================================
' Назначение
' Открытие окна диалога файлов
' Параметры:
' strFilter - строка фильтра
' strIniFile - файл инициализации
' strTitleDlg - заголовок окна
' strDefExt - расширение по умолчанию
' strCurDir - текущая папка
'
Public Function fGetSaveFileName( _
hwnd As Long, _
strFilter As String, _
strIniFile As String, _
strTitleDlg As String, _
strDefExt As String, _
strCurDir As String) As String
Dim OFNAME As OPENFILENAME 'Назначаем переменную для файла
Dim flag As Boolean
'Заполним структуру перед вызовом GetOpenFileName
With OFNAME
.lStructSize = Len(OFNAME) 'Размер структуры в байтах
.hwndOwner = hwnd 'Указатель окна
.lpstrFilter = strFilter 'Фильтр отбора
.nFilterIndex = 1 'Индекс первой пары строк фильтра
.lpstrFile = strIniFile & String$(512 - Len(strIniFile), 0) 'Полное имя файла
.nMaxFile = 511 'Размер буфера файла
.lpstrFileTitle = String$(512, 0) 'Только имя файла окна
.nMaxFileTitle = 511 'Размер буфера заголовка
.lpstrTitle = strTitleDlg 'Заголовок окна диалога
.flags = OFN_FILEMUSTEXIST 'Типы читаемых файлов
.lpstrDefExt = strDefExt 'Расширение файла по умолчанию
.lpstrInitialDir = strCurDir 'Каталог файлов по умолчанию
.hInstance = 0 'Идентификатор блока данных для OFN_ENABLETEMPLATE
.lpstrCustomFilter = 0 'Дополнительные фильтры, см. ниже
.nMaxCustFilter = 0 'не менее 40, 0 - игнорируется
.nFileOffset = 0 'Определяет смещение имени
.nFileExtension = 0 'Определяет расширение
.lCustData = 0 'Для собственных окон
.lpfnHook = 0 'Указатель на функцию фильтра
.lpTemplateName = 0 'Собственный диалог
'*** Старт
flag = apiGetSaveFileName(OFNAME) 'Общий случай
If flag Then 'Открываем диалог и находим имя файла
fGetSaveFileName = Left(.lpstrFile, InStr(.lpstrFile, Chr(0)) - 1)
Else
fGetSaveFileName = ""
End If
End With
End Function
'==============================================================
' Выполнение действий
Public Function fOfficeGetFile(strTitle As String, strInitDir As String, strFilter As String, Optional officeFlags As Long) As String
Dim lngFlags As Long
Dim gfni As accOfficeGetFileNameInfo
On Error GoTo 999
With gfni
If officeFlags <> 0 Then .lngFlags = officeFlags
.strFilter = strFilter
.strFile = ""
.strDlgTitle = "Выберите файл"
.strOpenTitle = ""
.strInitialDir = strInitDir
.hwndOwner = Application.hWndAccessApp
End With
If fOfficeGetFileName(gfni, -1) = 0 Then
fOfficeGetFile = Trim(gfni.strFile)
Else
fOfficeGetFile = ""
End If
Exit Function
999:
MsgBox Err.Description
Err.Clear
End Function
|
