MyTetra Share
Делитесь знаниями!
012. Диалог открытия файлов Microsoft Office
Время создания: 16.03.2019 23:43
Раздел: !Закладки - VBA - Access - leadersoft.ru
Запись: adgaver/mytetra_base_New/master/base/1531371423lx8766pwa3/text.html на raw.githubusercontent.com

012. Диалог открытия файлов Microsoft Office

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

Все примеры Microsoft Access

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

Так же в этом разделе:
 
MyTetra Share v.0.55
Яндекс индекс цитирования