TopPicLogo TopPicText

Диалог открытия Файла (API)

Option Explicit

'--------------------------------------------------------------------
' Module    : modOpenFileDialog_API
' Version   : 003
' Author    : es
' Date      : 06.08.2016
' Purpose   : Диалог открытия Файла (API)
'--------------------------------------------------------------------
'Параметры:
'InitDir            - начальная папка (по умолчанию : InitDir = CurrentProject.Path)
'strFlNameOrMask    - начальное имя файла или маска фаилов
'Функция возвращает: либо полный путь к файлу,
'                    либо пустую строку (в случае если была нажата кнопка "Отмена").
'--------------------------------------------------------------------
'Примеры вызова функции:
'?OpenFile("", "ReportsDB?mdb", "MS Access Database (*.mdb); *.mdb; All Files (*.*); *.*")
'...
'Dim strFileName As String
'    strFileName = OpenFile("C:\", "")
'или
'    strFileName = OpenFile(CurrentProject.Path, "northwind.mdb")
'или
'    strFileName = OpenFile("", "")
'--------------------------------------------------------------------

Private Type tOPENFILENAME
    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

Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHOWHELP = &H10

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As tOPENFILENAME) As Boolean
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As tOPENFILENAME) As Boolean

Public Function OpenFile(ByVal InitDir As String, ByVal strFlNameOrMask As String, _
        Optional strPairFilter As String = "All Files (*.*); *.*", _
        Optional strTitle As String) As String
'strPairFilter - УКАЗЫВАЕМ ПАРАМИ - "Название; Расширение"
'-------------------------------------------------------------
Dim strFile As String * 512
Dim ofn As tOPENFILENAME
Dim f As String
Dim p%

'--------------------------------------------------------------------
On Error GoTo OpenFile_Err
    ofn.hwndOwner = Application.hWndAccessApp
    ofn.hInstance = 0
    ofn.lpstrCustomFilter = 0
    ofn.nMaxCustrFilter = 0
    ofn.lpfnHook = 0
    ofn.lpTemplateName = 0
    ofn.lCustrData = 0

'Готовим ыильтр для поиска файлов Типа: "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
    f = Replace(strPairFilter, "  ", "") ' Двойные пробелы (ну мало ли ..)
    f = Replace(f, "; ", ";")            ' Разделитель с пробелом на один разделитель
    f = Replace(f, ";", Chr$(0))         ' Готово!
    ofn.lpstrFilter = f & Chr$(0)
    
    ofn.nFilterIndex = 1  'All Files (*.*) или что будет первой парой

    ofn.lpstrFile = strFlNameOrMask & String$(512 - Len(strFlNameOrMask), 0)
    ofn.nMaxFile = 511

    ofn.lpstrFileTitle = String$(512, 0)
    ofn.nMaxFileTitle = 511

' Заголовок окна
    If strTitle = "" Then
        ofn.lpstrTitle = "Поиск файла: " & strFlNameOrMask
    Else
        ofn.lpstrTitle = strTitle
    End If
    
    If InitDir = "" Then InitDir = CurrentProject.Path
    ofn.lpstrInitialDir = InitDir

' Расширение файла
    'ofn.lpstrDefExt = strPointExt
    
    ofn.Flags = OFN_FILEMUSTEXIST + OFN_PATHMUSTEXIST
    ofn.lStructSize = Len(ofn)
    If GetOpenFileName(ofn) Then
        p% = InStr(1, ofn.lpstrFile, Chr$(0))
        OpenFile = Left(ofn.lpstrFile, p% - 1)
    Else
        OpenFile = ""
    End If


OpenFile_Bye:
    Exit Function

OpenFile_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: OpenFile", vbCritical, "Error!"
    Resume OpenFile_Bye
End Function

Назад ToTop
L.E. 06.08.2016
Рейтинг@Mail.ru