VBA, MS Access MS Access в примерах

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

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

#If VBA7 Then
    Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As LongPtr
        hInstance As LongPtr
        lpstrFilter As String
        lpstrCustomFilter As String
        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 LongPtr
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type
#Else
    Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        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 String
    End Type
#End If
'-------------------------------------------------------------
'Декларация API ...
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
            "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
'-------------------------------------------------------------


Public Function OpenFileDialog(ByVal sInitDir As String, ByVal sFileNameOrMask As String, _
                Optional sPairFilter As String = "All Files (*.*); *.*") As String
Dim OpenFile    As OPENFILENAME
Dim lReturn     As Long
Dim sFilesFilter As String
  
  
    OpenFile.lpstrFilter = ""
    OpenFile.nFilterIndex = 1
    OpenFile.hwndOwner = 0
    OpenFile.lpstrFile = String(257, 0)
    #If VBA7 Then
        OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = LenB(OpenFile)
    #Else
        OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = Len(OpenFile)
    #End If
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    
    If sInitDir = "" Then sInitDir = CurrentProject.Path
    OpenFile.lpstrInitialDir = sInitDir
    'OpenFile.lpstrInitialDir = "C:\"
    
    OpenFile.lpstrTitle = "Поиск файла: " & sFileNameOrMask
    'OpenFile.lpstrTitle = strTitle
    
    
'Готовим фильтр для поиска файлов Типа: "All Files (*.*)" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
    sFilesFilter = Replace(sPairFilter, "  ", " ") ' Двойные пробелы (ну мало ли ..)
    sFilesFilter = Replace(sFilesFilter, "; ", ";")             ' Разделитель с пробелом на один разделитель
    sFilesFilter = Replace(sFilesFilter, ";", Chr$(0))          ' Готово!
    OpenFile.lpstrFilter = sFilesFilter & Chr$(0)
    OpenFile.nFilterIndex = 1  'All Files (*.*) или что будет первой парой
    OpenFile.lpstrFile = sFileNameOrMask & String$(512 - Len(sFileNameOrMask), 0)
    

    OpenFile.flags = 0
    lReturn = GetOpenFileName(OpenFile)
  
    If lReturn = 0 Then
        OpenFileDialog = ""
    Else
        OpenFileDialog = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If
  
End Function



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