VERSION  1 . 0  CLASS
BEGIN
  MultiUse = - 1   'True
END
Attribute VB_Name = "Form_dlgLinkTables"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

Private Sub Form_Open(Cancel As Integer)
On Error GoTo Err_Label

    Dim ref As Reference

    Me.txtDataPath = Application.CurrentProject.Path
    Me.txtProvider = "Microsoft.Jet.OLEDB.4.0;"
    Me!btnLinkData.Enabled = False
    Me!btnClose.Enabled = False

EXIT_LABEL:
    Exit Sub

Err_Label:
    MsgBox Err.Description
    Resume EXIT_LABEL
    
End Sub

Private Sub btnFindData_Click()

    Const acSysCmdAccessDir =  9 
    Dim strSearchPath As String
    
    If IsNull(Me.txtDataPath) Then
        strSearchPath = SysCmd(acSysCmdAccessDir) & "*.mdb"
    Else
        If Trim(Me.txtDataPath) = "" Then
            strSearchPath = SysCmd(acSysCmdAccessDir) & "*.mdb"
        End If
    End If
    
    ' Открывает диалоговое окно для поиска базы данных
    ' пользователем. Возвращает полный путь к файлу MDB
    
    Dim msaof As MSA_OPENFILENAME
     
    ' Задает параметры диалогового окна.
    msaof.strDialogTitle = "Поиск файла данных"
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Базы данных", "*.mdb")
     
    ' Вызывает подпрограмму диалогового окна.
    MSA_GetOpenFileName msaof
     
    ' Возвращает путь и имя файла.
    Me.txtDataPath = Trim(msaof.strFullPathReturned)
     
    If Not IsNull(Me!txtDataPath) Then
        If Len(Trim(Me!txtDataPath)) Then
            btnLinkData.Enabled = True
        Else
            btnLinkData.Enabled = False
        End If
    Else
       btnLinkData.Enabled = False
    End If
      
End Sub

Private Sub btnProvider_Click()

    Dim s As String
    If MsgBox( _
        "Вы уверены, что хотите изменить провайдера данных на другое значение ?" & vbCrLf & vbCrLf & _
        "Неверное значение этого параметра сделает систему неработоспособной." & vbCrLf & _
        "Рекомендуемое значение [Microsoft.Jet.OLEDB.4.0]", vbQuestion + vbYesNo) = vbYes Then
        s = InputBox("Введите наименование провайдера данных", , Me.txtProvider)
        If Len(s) >  0  Then
            Me.txtDataPath = s
        End If
    End If

End Sub

Private Sub btnCheckData_Click()
On Error GoTo Err_Label

    Dim cat As ADOX.Catalog, tbl As ADOX.Table, prop  As ADOX.Property
    Dim cnn As ADODB.Connection, rs As ADODB.Recordset
    
    Set cat = New ADOX.Catalog
    Set cat.ActiveConnection = CurrentProject.Connection
    
    Dim i As Integer, n As Integer, s As String, b As Boolean
    i =  0 : n =  0 : s = "": b = True
    For Each tbl In cat.Tables
        If Left(tbl.Name,  1 ) <> "~" And Left(tbl.Name,  4 ) <> "MSys" And _
            tbl.Properties("Jet OLEDB:Create Link") = True And _
            Len(tbl.Properties("Jet OLEDB:Link Datasource")) >  0  And _
            Len(tbl.Properties("Jet OLEDB:Remote Table Name")) >  0  _
        Then
On Error GoTo Err_Connect
            Set cnn = CurrentProject.Connection
            Set rs = cnn.Execute("SELECT * FROM " & tbl.Name, i)
            s = s & tbl.Name & "; "
            n = n +  1 
Next_Table:
        End If
    Next tbl
    Me!btnClose.Enabled = b
    If b Then
        MsgBox _
            "Успешно проверено " & CStr(n) & " таблиц(ы) в файле данных:" _
            & vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    Else
        MsgBox _
            "Не все таблицы были успешно проверены. " & _
            "Число проверенных таблиц: " & CStr(n) & _
            vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    End If
    Exit Sub

    '-2147467259
    'Не удается найти файл '<имя файла>.mdb'.
    '-2147217865
    'Ядро базы данных Microsoft Jet не может найти
    'входную таблицу или запрос 'tbPerson'.
    'Проверьте существование таблицы или запроса и правильность имени.
Err_Connect:
    b = False
    Dim s1 As String
    If Err.Number = - 2147467259  Then
        s1 = "Не удается найти файл '" & _
            tbl.Properties("Jet OLEDB:Link Datasource") & "'" & _
            vbNewLine & vbNewLine & _
            "Проверьте правильно ли заданы путь к файлу данных с таблицами " & _
            "и имя этого файла. " & _
            vbNewLine & vbNewLine & _
            "Укажите этот файл заново при помощи кнопки 'Найти файл'."
    ElseIf Err.Number = - 2147217865  Then
        s1 = "Требуемая таблица '" & _
            tbl.Properties("Jet OLEDB:Remote Table Name") & "' " & _
            "не найдена в данном файле '" & _
            tbl.Properties("Jet OLEDB:Link Datasource") & "' " & _
            vbNewLine & vbNewLine & _
            "Проверьте существование таблицы и правильность ее имени."
    Else
        s1 = "При подключении таблиц возникла неожиданная ошибка." & _
        vbNewLine & vbNewLine & _
        "Код: " & CStr(Err.Number) & " Описание: " & Err.Description
    End If
    If _
        MsgBox(s1 & vbNewLine & vbNewLine & _
        "Продолжить проверку таблиц ?", _
        vbCritical + vbYesNo) = vbYes _
    Then
        Resume Next_Table
    Else
        Exit Sub
    End If
        
Err_Label:
    If MsgBox( _
        "При выполнении программы возникла неожиданная ошибка." & _
        vbNewLine & vbNewLine & _
        "Код: " & CStr(Err.Number) & " Описание: " & Err.Description & _
        vbNewLine & vbNewLine & _
        "Продолжить выполнении программы ?", _
        vbCritical + vbYesNo) = vbYes Then
        Resume Next
    Else
        Exit Sub
    End If
    
End Sub

Private Sub btnLinkData_Click()

    Dim cat As ADOX.Catalog, tbl As ADOX.Table, prop  As ADOX.Property
    Dim s As String, n As Integer, b As Boolean
    
    Set cat = New ADOX.Catalog
    Set cat.ActiveConnection = CurrentProject.Connection
    n =  0 : s = "": b = True
    For Each tbl In cat.Tables
        If Left(tbl.Name,  1 ) <> "~" And Left(tbl.Name,  4 ) <> "MSys" And _
            tbl.Properties("Jet OLEDB:Create Link") = True And _
            Len(tbl.Properties("Jet OLEDB:Link Datasource")) >  0  And _
            Len(tbl.Properties("Jet OLEDB:Remote Table Name")) >  0  _
        Then
On Error GoTo Err_Connect
            tbl.Properties("Jet OLEDB:Link Datasource") = Me.txtDataPath
            s = s & tbl.Name & "; "
            n = n +  1 
On Error GoTo  0 
Next_Table:
        End If
    Next tbl
    
    Me!btnClose.Enabled = b
    If b Then
        MsgBox _
            "Успешно подключены " & CStr(n) & " таблиц(ы) в файле данных:" _
            & vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    Else
        MsgBox _
            "Не все таблицы были успешно пподключены. " & _
            "Число подключенных таблиц: " & CStr(n) & _
            vbCrLf & vbCrLf & s, vbInformation + vbOKOnly
    End If
    Exit Sub
    
Err_Connect:
    b = False
    Dim s1 As String
    s1 = _
        "Невозможно подключит таблицу '" & tbl.Name & "'" & _
        vbNewLine & vbNewLine & _
        "Jet OLEDB:Link Datasource='" & tbl.Properties("Jet OLEDB:Link Datasource") & "'" & _
        vbNewLine & _
        "Jet OLEDB:Remote Table Name='" & tbl.Properties("Jet OLEDB:Remote Table Name") & "'" & _
        vbNewLine & vbNewLine & _
        "Код: " & CStr(Err.Number) & " Описание: " & Err.Description & _
        vbNewLine & vbNewLine & _
        "Проверьте правильно ли заданы путь к файлу данных с таблицами " & _
        "и имя этого файла, а так же существование таблицы " & _
        "и правильность ее имени. " & _
        vbNewLine & vbNewLine & _
        "При необходимоcти укажите этот файл заново " & _
        "при помощи кнопки 'Найти файл'."
    If _
        MsgBox(s1 & vbNewLine & vbNewLine & _
        "Продолжить подключение таблиц ?", _
        vbCritical + vbYesNo) = vbYes _
    Then
        Resume Next_Table
    Else
        Exit Sub
    End If

End Sub

Private Sub btnClose_Click()

    DoCmd.Close acForm, Me.Name

End Sub

Private Sub btnExit_Click()

    Application.Quit

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                    ÎáíîâëåíèåÑâÿçåéÒàáëèö                         '
'                                                                   '
'      Äàííûé ìîäóëü ñîäåðæèò ôóíêöèè, îáíîâëÿþùèå ñâÿçè ñ          '
'      òàáëèöàìè áàçû äàííûõ Áîðåé, åñëè òàáëèöû íåäîñòóïíû.        '
'                                                                   '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Database

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

Public Type MSA_OPENFILENAME
    ' Îòáîð ñòðîê, èñïîëüçóåìûõ â ôèëüòðàõ îêíå äèàëîãà "Îòêðûòèå".
    ' Äëÿ ñîçäàíèÿ ôèëüòðîâ âûçûâàåò MSA_CreateFilterString().
    ' Çíà÷åíèå ïî óìîë÷àíèþ = Âñå ôàéëû, *.*
    strFilter As String
    ' Èñõîäíûé ôèëüòð.
    ' Çíà÷åíèå ïî óìîë÷àíèþ = 1.
    lngFilterIndex As Long
    ' Èñõîäíûé êàòàëîã, äëÿ êîòîðîãî îòêðûâàåòñÿ äèàëîãîâîå îêíî.
    ' Çíà÷åíèå ïî óìîë÷àíèþ = òåêóùèé ðàáî÷èé êàòàëîã.
    strInitialDir As String
    ' Èñõîäíîå èìÿ ôàéëîâ, âûâîäÿùèõñÿ â äèàëîãîâîì îêíå.
    ' Çíà÷åíèå ïî óìîë÷àíèþ = "".
    strInitialFile As String
    strDialogTitle As String
    ' Ñòàíäàðòíîå ðàñøèðåíèå èìåíè ôàéëà, åñëè íå óêàçàíî ïîëüçîâàòåëåì.
    ' Çíà÷åíèå ïî óìîë÷àíèþ = ñèñòåìíûå çíà÷åíèÿ (Îòêðûòü, Ñîõðàíèòü).
    strDefaultExtension As String
    ' Èñïîëüçóåìûå ôëàãè (ñì. ñïèñîê êîíñòàíò).
    ' Çíà÷åíèå ïî óìîë÷àíèþ = îòñóòñòâèå ôëàãîâ.
    lngFlags As Long
    ' Ïîëíûé ïóòü ê âûáðàííîìó ôàéëó. Åñëè ïîëüçîâàòåëü óêàçàë
    ' íåñóùåñòâóþùèé ôàéë, ïî êîìàíäå "Îòêðûòü" âîçâðàùàåòñÿ
    ' òîëüêî òåêñò èç ïîëÿ "Èìÿ ôàéëà".
    strFullPathReturned As String
    ' Èìÿ âûáðàííîãî ôàéëà.
    strFileNameReturned As String
    ' Ïîçèöèÿ â ïîëíîì ïóòè (strFullPathReturned), ñ êîòîðîé
    ' íà÷èíàåòñÿ èìÿ ôàéëà (strFileNameReturned).
    intFileOffset As Integer
    ' Ïîçèöèÿ â ïîëíîì ïóòè (strFullPathReturned), ñ êîòîðîé
    ' íà÷èíàåòñÿ ðàñøèðåíèå èìåíè ôàéëà.
    intFileExtension As Integer
End Type

Const ALLFILES = "Âñå ôàéëû"

Type OPENFILENAME
    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

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

Function FindDataFile(strSearchPath) As String
' Îòêðûâàåò äèàëîãîâîå îêíî äëÿ ïîèñêà áàçû äàííûõ Áîðåé
' ïîëüçîâàòåëåì. Âîçâðàùàåò ïîëíûé ïóòü ê ôàéëó Áîðåé.

    Dim msaof As MSA_OPENFILENAME
    
    ' Çàäàåò ïàðàìåòðû äèàëîãîâîãî îêíà.
    msaof.strDialogTitle = "Ïîèñê ôàéëà äàííûõ"
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Áàçû äàííûõ", "*.mdb")
    
    ' Âûçûâàåò ïîäïðîãðàììó äèàëîãîâîãî îêíà.
    MSA_GetOpenFileName msaof
    
    ' Âîçâðàùàåò ïóòü è èìÿ ôàéëà.
    FindDataFile = Trim(msaof.strFullPathReturned)
    
End Function

Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Ñîçäàåò èç ïåðåäàííûõ àðãóìåíòîâ ñòðîêó ôèëüòðà.
' Âîçâðàùàåò "", åñëè àðãóìåíòû íå ïåðåäàíû.
' Îæèäàåòñÿ ÷åòíîå ÷èñëî àðãóìåíòîâ (èìÿ ôèëüòðà, ðàñøèðåíèå).
' Åñëè ïåðåäàíî íå÷åòíîå ÷èñëî àðãóìåíòîâ, äîáàâëÿåòñÿ "*.*".
    
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = UBound(varFilt)
    If (intNum <> - 1 ) Then
        For intRet =  0  To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod  2  =  0  Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
' Ñîçäàåò ñòðîêó ôèëüòðà èç ñòðîê, ðàçäåëÿåìûõ âåðòèêàëüíîé ÷åðòîé ("|").
' Ñòðîêè äîëæíû ñîñòîÿòü èç ïàð ñòðîêà|ðàñøèðåíèå, íàïðèìåð, "Áàçû äàííûõ Access|*.mdb|Âñå ôàéëû|*.*"
' Åñëè äëÿ ïîñëåäíåé ïàðû îòñóòñòâóåò ðàñøèðåíèå, äîáàâëÿåòñÿ "*.*".
' Äàííàÿ ïðîãðàììà èãíîðèðóåò ëþáûå ïóñòûå ñòðîêè, ò.å. ïàðû "||".
' Âîçâðàùàåò ïóñòóþ ñòðîêó "", åñëè âñå ïåðåäàííûå ñòðîêè ïóñòûå.
 
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum =  0 
    intPos =  1 
    intLastPos =  1 

    ' Äîáàâëÿåò ñòðîêè ïî ìåðå íàõîæäåíèÿ ñèìâîëîâ âåðòèêàëüíîé
    ' ÷åðòû. Èãíîðèðóåò íåðàçðåøåííûå ïóñòûå ñòðîêè.
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum +  1 
            intLastPos = intPos +  1 
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos +  1 
        End If
    Loop Until (intPos =  0 )
        
    ' Ïðèíèìàåò ïîñëåäíþþ ñòðîêó, åñëè îíà ñóùåñòâóåò
    ' (åñëè strFilterIn íå çàêàí÷èâàåòñÿ âåðòèêàëüíîé ÷åðòîé).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos +  1 ) & vbNullChar
        intNum = intNum +  1 
    End If
    
    ' Äîáàâëÿåò *.*, åñëè ïîñëåäíÿÿ ñòðîêà íå ñîäåðæèò ðàñøèðåíèÿ.
    If intNum Mod  2  =  1  Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    
    ' Åñëè èìååòñÿ ôèëüòð, äîáàâëÿåò çàâåðøàþùèé ïóñòîé ñèìâîë.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    
    MSA_ConvertFilterString = strFilter
End Function

Public Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Îòêðûâàåò äèàëîãîâîå îêíî ñîõðàíåíèÿ ôàéëîâ.
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' Îòêðûâàåò äèàëîãîâîå îêíî ñîõðàíåíèÿ ôàéëà ñî ñòàíäàðòíûìè ïàðàìåòðàìè.
    
    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetSaveFileName = strRet
End Function

Public Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Îòêðûâàåò äèàëîãîâîå îêíî "Îòêðûòèå".
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
    
End Function

Function MSA_SimpleGetOpenFileName() As String
' Îòêðûâàåò äèàëîãîâîå îêíî ñî ñòàíäàðòíûìè ïàðàìåòðàìè.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetOpenFileName = strRet
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' Äàííàÿ ïðîöåäóðà îñóùåñòâëÿåò ïåðåõîä îò ñòðóêòóðû win32
' ê ñòðóêòóðå MSAccess.
   
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) -  1 )
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' Äàííàÿ ïðîöåäóðà îñóùåñòâëÿåò ïåðåõîä îò ñòðóêòóðû MSAccess
' ê ñòðóêòóðå win32.
    
    Dim strFile As String *  512 

    ' Èíèöèàëèçèðóåò íåêîòîðûå êîìïîíåíòû ñòðóêòóðû.
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance =  0 
    of.lpstrCustomFilter =  0 
    of.nMaxCustrFilter =  0 
    of.lpfnHook =  0 
    of.lpTemplateName =  0 
    of.lCustrData =  0 
    
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
    of.lpstrFile = msaof.strInitialFile _
        & String( 512  - Len(msaof.strInitialFile),  0 )
    of.nMaxFile =  511 
    of.lpstrFileTitle = String( 512 ,  0 )
    of.nMaxFileTitle =  511 
    of.lpstrTitle = msaof.strDialogTitle
    of.lpstrInitialDir = msaof.strInitialDir
    of.lpstrDefExt = msaof.strDefaultExtension
    of.Flags = msaof.lngFlags
    of.lStructSize = Len(of)
    
End Sub

Attribute VB_Name = "LinkData"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                    ОбновлениеСвязейТаблиц                         '
'                                                                   '
'      Данный модуль содержит функции, обновляющие связи с          '
'      таблицами базы данных Борей, если таблицы недоступны.        '
'                                                                   '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Database

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

Public Type MSA_OPENFILENAME
    ' Отбор строк, используемых в фильтрах окне диалога "Открытие".
    ' Для создания фильтров вызывает MSA_CreateFilterString().
    ' Значение по умолчанию = Все файлы, *.*
    strFilter As String
    ' Исходный фильтр.
    ' Значение по умолчанию = 1.
    lngFilterIndex As Long
    ' Исходный каталог, для которого открывается диалоговое окно.
    ' Значение по умолчанию = текущий рабочий каталог.
    strInitialDir As String
    ' Исходное имя файлов, выводящихся в диалоговом окне.
    ' Значение по умолчанию = "".
    strInitialFile As String
    strDialogTitle As String
    ' Стандартное расширение имени файла, если не указано пользователем.
    ' Значение по умолчанию = системные значения (Открыть, Сохранить).
    strDefaultExtension As String
    ' Используемые флаги (см. список констант).
    ' Значение по умолчанию = отсутствие флагов.
    lngFlags As Long
    ' Полный путь к выбранному файлу. Если пользователь указал
    ' несуществующий файл, по команде "Открыть" возвращается
    ' только текст из поля "Имя файла".
    strFullPathReturned As String
    ' Имя выбранного файла.
    strFileNameReturned As String
    ' Позиция в полном пути (strFullPathReturned), с которой
    ' начинается имя файла (strFileNameReturned).
    intFileOffset As Integer
    ' Позиция в полном пути (strFullPathReturned), с которой
    ' начинается расширение имени файла.
    intFileExtension As Integer
End Type

Const ALLFILES = "Все файлы"

Type OPENFILENAME
    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

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

Function FindDataFile(strSearchPath) As String
' Открывает диалоговое окно для поиска базы данных Борей
' пользователем. Возвращает полный путь к файлу Борей.

    Dim msaof As MSA_OPENFILENAME
    
    ' Задает параметры диалогового окна.
    msaof.strDialogTitle = "Поиск файла данных"
    msaof.strInitialDir = strSearchPath
    msaof.strFilter = MSA_CreateFilterString("Базы данных", "*.mdb")
    
    ' Вызывает подпрограмму диалогового окна.
    MSA_GetOpenFileName msaof
    
    ' Возвращает путь и имя файла.
    FindDataFile = Trim(msaof.strFullPathReturned)
    
End Function

Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Создает из переданных аргументов строку фильтра.
' Возвращает "", если аргументы не переданы.
' Ожидается четное число аргументов (имя фильтра, расширение).
' Если передано нечетное число аргументов, добавляется "*.*".
    
    Dim strFilter As String
    Dim intRet As Integer
    Dim intNum As Integer

    intNum = UBound(varFilt)
    If (intNum <> - 1 ) Then
        For intRet =  0  To intNum
            strFilter = strFilter & varFilt(intRet) & vbNullChar
        Next
        If intNum Mod  2  =  0  Then
            strFilter = strFilter & "*.*" & vbNullChar
        End If
        
        strFilter = strFilter & vbNullChar
    Else
        strFilter = ""
    End If

    MSA_CreateFilterString = strFilter
End Function

Function MSA_ConvertFilterString(strFilterIn As String) As String
' Создает строку фильтра из строк, разделяемых вертикальной чертой ("|").
' Строки должны состоять из пар строка|расширение, например, "Базы данных Access|*.mdb|Все файлы|*.*"
' Если для последней пары отсутствует расширение, добавляется "*.*".
' Данная программа игнорирует любые пустые строки, т.е. пары "||".
' Возвращает пустую строку "", если все переданные строки пустые.
 
    Dim strFilter As String
    Dim intNum As Integer, intPos As Integer, intLastPos As Integer

    strFilter = ""
    intNum =  0 
    intPos =  1 
    intLastPos =  1 

    ' Добавляет строки по мере нахождения символов вертикальной
    ' черты. Игнорирует неразрешенные пустые строки.
    Do
        intPos = InStr(intLastPos, strFilterIn, "|")
        If (intPos > intLastPos) Then
            strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
            intNum = intNum +  1 
            intLastPos = intPos +  1 
        ElseIf (intPos = intLastPos) Then
            intLastPos = intPos +  1 
        End If
    Loop Until (intPos =  0 )
        
    ' Принимает последнюю строку, если она существует
    ' (если strFilterIn не заканчивается вертикальной чертой).
    intPos = Len(strFilterIn)
    If (intPos >= intLastPos) Then
        strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos +  1 ) & vbNullChar
        intNum = intNum +  1 
    End If
    
    ' Добавляет *.*, если последняя строка не содержит расширения.
    If intNum Mod  2  =  1  Then
        strFilter = strFilter & "*.*" & vbNullChar
    End If
    
    ' Если имеется фильтр, добавляет завершающий пустой символ.
    If strFilter <> "" Then
        strFilter = strFilter & vbNullChar
    End If
    
    MSA_ConvertFilterString = strFilter
End Function

Public Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Открывает диалоговое окно сохранения файлов.
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    of.Flags = of.Flags Or OFN_HIDEREADONLY
    intRet = GetSaveFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetSaveFileName = intRet
End Function

Function MSA_SimpleGetSaveFileName() As String
' Открывает диалоговое окно сохранения файла со стандартными параметрами.
    
    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetSaveFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetSaveFileName = strRet
End Function

Public Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Открывает диалоговое окно "Открытие".
    
    Dim of As OPENFILENAME
    Dim intRet As Integer

    MSAOF_to_OF msaof, of
    intRet = GetOpenFileName(of)
    If intRet Then
        OF_to_MSAOF of, msaof
    End If
    MSA_GetOpenFileName = intRet
    
End Function

Function MSA_SimpleGetOpenFileName() As String
' Открывает диалоговое окно со стандартными параметрами.

    Dim msaof As MSA_OPENFILENAME
    Dim intRet As Integer
    Dim strRet As String
    
    intRet = MSA_GetOpenFileName(msaof)
    If intRet Then
        strRet = msaof.strFullPathReturned
    End If
    
    MSA_SimpleGetOpenFileName = strRet
End Function

Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' Данная процедура осуществляет переход от структуры win32
' к структуре MSAccess.
   
    msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) -  1 )
    msaof.strFileNameReturned = of.lpstrFileTitle
    msaof.intFileOffset = of.nFileOffset
    msaof.intFileExtension = of.nFileExtension
End Sub

Private Sub MSAOF_to_OF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' Данная процедура осуществляет переход от структуры MSAccess
' к структуре win32.
    
    Dim strFile As String *  512 

    ' Инициализирует некоторые компоненты структуры.
    of.hwndOwner = Application.hWndAccessApp
    of.hInstance =  0 
    of.lpstrCustomFilter =  0 
    of.nMaxCustrFilter =  0 
    of.lpfnHook =  0 
    of.lpTemplateName =  0 
    of.lCustrData =  0 
    
    If msaof.strFilter = "" Then
        of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
    Else
        of.lpstrFilter = msaof.strFilter
    End If
    of.nFilterIndex = msaof.lngFilterIndex
    of.lpstrFile = msaof.strInitialFile _
        & String( 512  - Len(msaof.strInitialFile),  0 )
    of.nMaxFile =  511 
    of.lpstrFileTitle = String( 512 ,  0 )
    of.nMaxFileTitle =  511 
    of.lpstrTitle = msaof.strDialogTitle
    of.lpstrInitialDir = msaof.strInitialDir
    of.lpstrDefExt = msaof.strDefaultExtension
    of.Flags = msaof.lngFlags
    of.lStructSize = Len(of)
    
End Sub