LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
У Microsoft Office есть специальный диалог открытия файлов, который имеет много интересных свойств. Он лучше диалога Windows. В этом примере показано как можно его использовать.
Свойства продукта

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\14 Файлы\la_files.mdb
 Язык интерфейса: Русский

   

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 IntegerAs 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 IntegerAs 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 StringAs 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 StringAs 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 StringOptional officeFlags As LongAs 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

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access