Диалог открытия Файла (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