Связанные таблицы

Option Explicit
 
Dim tbl As DAO.TableDef
Public retval As Boolean
Type tagOPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   strFilter As String
   strCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   strFile As String
   nMaxFile As Long
   strFileTitle As String
   nMaxFileTitle As Long
   strInitialDir As String
   strTitle As String
   flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   strDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
 
 
Public Function CheckPlaceBases()
  ' Поиск файлов со связанными таблицами
  Dim sp, sf As String
  Dim rs As DAO.Recordset
  Dim strFullPath As String
  Dim intPos As Integer
 
  ' Проверяю все таблицы. Не знаю способа лучше перебора всех таблиц
  On Error Resume Next
  For Each tbl In CurrentDb.TableDefs
    If Left(tbl.Name, 4) <> "MSys" Then
      If tbl.Fields(0).Name = "" Then
      End If
    End If
    If Err.Number <> 0 Then
      Exit For ' Возможно, таблица не найдена, шагаем дальше
    End If
  Next
  If Err.Number = 0 Then Exit Function ' Все в порядке
 
  strFullPath = CurrentDb.Name
  ' Ищем последний слэш в полном адресе к текущей базе
  intPos = InStrRev(strFullPath, "\")
  If intPos > 0 Then
    strFullPath = Left(strFullPath, intPos)
  End If
  
  ' Спрашиваю, выполнить ли поиск? Если нет, выхожу из программы
  If MsgBox("Не могу восстановить подключение к базе данных." & Chr(10) & _
            "Возможно, файл БД был перемещен." & Chr(10) & _
            "Попробовать найти его?", vbYesNo, "Ошибка подключения к базе") = vbYes Then
    ' Подключаю таблицу известных путей. Если ее нет, создаю
    Err.Clear
    Set rs = CurrentDb.OpenRecordset("сПутиКтаблицам")
    If Err.Number <> 0 Then
      CurrentDb.Execute "create table сПутиКтаблицам (ПутьКтаблице text(250))"
      Set rs = CurrentDb.OpenRecordset("сПутиКтаблицам")
    End If
    
    For Each tbl In CurrentDb.TableDefs
      On Error Resume Next
      If tbl.Fields(0).Name = "" Then
      End If ' Если произойдет ошибка - возможно, таблица не подключена
      If Err.Number <> 0 And Len(tbl.Connect) Then
        ' Проверяю наличие таблицы по последним известным путям.
        rs.MoveFirst ' Здесь м.б. ошибка, если нет текущей записи
        On Error GoTo 0
        Do Until rs.EOF
          ' Если таблица подцепилась, прекращаю перебор файлов и перехожу к следующей
          If TryConnectToTable(rs!ПутьКтаблице) Then Exit Do
          rs.MoveNext
        Loop
        
        If rs.EOF Then ' Если находимся в конце rs, то либо он пуст, _
                       ' либо файлы не найдены, либо ни в одном файле таблицы нет
          ' По последним известным путям таблица найдена не была,
          ' предлагаю найти файл самостоятельно.
          Do
            sp = ""
            If sf = "" Then
                  sf = ahtAddFilterItem(sf, "Файлы Microsoft Access", "*.mdb;*.mde;*.mda")
              sf = ahtAddFilterItem(sf, "Все файлы", "*.*")
              If MsgBox("Не могу восстановить связь с таблицей " & tbl.Name & _
                        " по известным путям." & Chr(10) & _
                        "Попробуете найти файл с таблицей самостоятельно?", _
                            vbYesNo) = vbYes Then
                sp = GetOpenFile(strFullPath, _
                        varTitleForDialog:="Выберите файл, содержащий " & _
                            tbl.Name, strFilter:=sf, lngFlags:=0)
              Else
                Exit Do
              End If
            Else
              If MsgBox("В этом файле таблица " & tbl.Name & _
                        " не найдена." & Chr(10) & _
                        "Хотите выбрать другой файл?", vbYesNo) = vbYes Then
                sp = GetOpenFile(varTitleForDialog:="Выберите файл, содержащий " & _
                            tbl.Name, strFilter:=sf, lngFlags:=0)
              Else
                Exit Do
              End If
            End If
          Loop While (TryConnectToTable(sp) = False)
          
          On Error Resume Next
          If tbl.Fields(0).Name <> "" Then
            ' Произойдет ошибка, если таблица не была подключена
          End If
          If Err.Number <> 0 Then
            ' Если файл не найден пользователем,
            'сообщаю об этом пользователю и продолжаю цикл
            MsgBox "Не все связи восстановлены!" & Chr(10) & _
                   "В работе программы возможны ошибки." & _
                   "Рекомендуется закрыть программу и обратиться к разработчику!"
          Else
            ' Если файл найден пользователем (не в rs), добавляю его в rs
            rs.AddNew
            rs!ПутьКтаблице = sp
            rs.Update
          End If
          On Error GoTo 0
        End If
      End If
      On Error GoTo 0
    Next tbl
    
    Set tbl = Nothing
    On Error Resume Next
    rs.Close
    On Error GoTo 0
    Set rs = Nothing
  Else
    MsgBox "Не все связи восстановлены!" & Chr(10) & _
           "В работе программы возможны ошибки." & _
           "Рекомендуется закрыть программу и обратиться к разработчику!"
  End If
End Function
 
Private Function TryConnectToTable(ByVal strPath As String) As Boolean
  Dim s As String
  
  On Error Resume Next
  If Len(Dir(strPath)) > 0 Then ' Файл есть, пробую подцепить таблицу
    s = tbl.Connect
    tbl.Connect = Left(s, InStr(s, ";DATABASE=") + 9) & strPath
    tbl.RefreshLink ' RefreshLink возвратит ошибку, если таблицы в файле нет
    If Err.Number <> 0 And InStr(strPath, "\") Then
      ' Попробуем, на случай, если это не .mdb файл, указать здесь имя папки без файла
      Err.Clear
      tbl.Connect = Left(tbl.Connect, InStrRev(tbl.Connect, "\"))
      tbl.RefreshLink
    End If
    TryConnectToTable = Not (Err.Number <> 0)
    If Err.Number <> 0 Then tbl.Connect = s
  End If
End Function
 
Public Function InStrRev(StringSource As String, StringTarget As String) As Integer
  Dim t As Long
  
  Do
    t = InStr(t + 1, StringSource, StringTarget)
  Loop While t > 0 And InStr(t + 1, StringSource, StringTarget) > 0
  InStrRev = t
End Function
 
'***************** Code Start **************
'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
 
Public Function GetOpenFile(Optional varDirectory As String, _
    Optional varTitleForDialog As String, _
    Optional strFilter As String, _
    Optional lngFlags As Long) As String
Dim varFileName As Variant
    ' Specify that the chosen file must already exist,
    ' don't change directories when you're done
    ' Also, don't bother displaying
    ' the read-only box. It'll only confuse people.
    If lngFlags Then _
   lngFlags = ahtOFN_FILEMUSTEXIST Or _
               ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
    If strFilter = "" Then _
       strFilter = ahtAddFilterItem(strFilter, _
               "All files (*.*)", "*.*")
' Now actually call to get the file name.
   varFileName = ahtCommonFileOpenSave( _
                   OpenFile:=True, _
                   InitialDir:=varDirectory, _
                   Filter:=strFilter, _
                   flags:=lngFlags, _
                   DialogTitle:=varTitleForDialog)
    If Not IsNull(varFileName) Then
       varFileName = TrimNull(varFileName)
    End If
   GetOpenFile = varFileName
End Function
 
Function ahtCommonFileOpenSave( _
            Optional ByRef flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal FileName As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hwnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant
' This is the entry point you'll use to call the common
' file open/save dialog. The parameters are listed
' below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFilename As String
Dim strFileTitle As String
Dim fResult As Boolean ' Give the dialog a caption title.
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(flags) Then flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
    If IsMissing(OpenFile) Then OpenFile = True
' Allocate string space for the returned strings.
   strFilename = Left(FileName & String(256, 0), 256)
   strFileTitle = String(256, 0)
' Set up the data structure before you call the function
    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFilename
        .nMaxFile = Len(strFilename)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .flags = flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
' Didn't think most people would want to deal with
' these options.
        .hInstance = 0
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
'New for NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
' This will pass the desired data structure to the
' Windows API, which will in turn it uses to display
' the Open/Save As Dialog.
    If OpenFile Then
       fResult = aht_apiGetOpenFileName(OFN)
    Else
       fResult = aht_apiGetSaveFileName(OFN)
    End If
 
' The function call filled in the strFileTitle member
' of the structure. You'll have to write special code
' to retrieve that if you're interested.
    If fResult Then
' You might care to check the Flags member of the
' structure to get information about the chosen file.
' In this example, if you bothered to pass in a
' value for Flags, we'll fill it in with the outgoing
' Flags value.
        If Not IsMissing(flags) Then flags = OFN.flags
       ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
       ahtCommonFileOpenSave = vbNullString
    End If
End Function
 
Function ahtAddFilterItem(strFilter As String, _
   strDescription As String, Optional varItem As Variant) As String
   ' Tack a new chunk onto the file filter.
   ' That is, take the old value, stick onto it the description,
   ' (like "Databases"), a null character, the skeleton
   ' (like "*.mdb;*.mda") and a final null character.
 
    If IsMissing(varItem) Then varItem = "*.*"
   ahtAddFilterItem = strFilter & _
               strDescription & vbNullChar & _
               varItem & vbNullChar
End Function
 
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
   intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
       TrimNull = Left(strItem, intPos - 1)
    Else
       TrimNull = strItem
    End If
End Function
'************** Code End *****************

private function ....
on error goto MyErr
MyErr:
if not HaveError(err.number ...) then resume
end function

public function HaveError(ErrNum, ...) as boolean
  if errnum=3024 or errnum=3044 then
    haveerror = not CheckPlaceBases
  endif
end function

Private Function TryConnectToTable(ByVal strPath As String) As Boolean
  Dim s As String
  
  On Error Resume Next
  If Len(Dir(strPath)) > 0 Then ' Файл есть, пробую подцепить таблицу
    s = tbl.Connect
    tbl.Connect = Left(s, InStr(s, ";DATABASE=") + 9) & strPath
    tbl.RefreshLink ' RefreshLink возвратит ошибку, если таблицы в файле нет
    If Err.Number <> 0 And InStr(strPath, "\") Then
      ' Попробуем, на случай, если это не .mdb файл, указать здесь имя папки без файла
      Err.Clear
      tbl.Connect = Left(tbl.Connect, InStrRev(tbl.Connect, "\"))
      tbl.RefreshLink
    End If
    TryConnectToTable = Not (Err.Number <> 0)
    If Err.Number <> 0 Then tbl.Connect = s
  End If
End Function