К сожалению не помню ссылку у меня тут в запасниках валялось :
придется листать ;))) но толково, половина кода нафиг не нужна ;)))
Это для 5aciJIa
Восстановление связей с линкованными таблицами при перемещении файлов
(обращений: 407 с 21.09.2004, уникальных IP: 255)
Разделы: Таблицы, ЧаВо (FAQ)
Описание: Часто вижу вопросы "как восстановить связи с линкованными таблицами при перемещении файлов?" Когда-то я себе писал такую процедурку для mdb, оказалось, что она работает и для таблиц Excel, DBF, а, возможно и для других типов. С таблицами ODBC я не работал, поэтому здесь о них и не думал.
Автор: Георгий Удалов (AKA GEO)
Добавил на сайт: geo 21.09.2004
Как с этим работать:
Следующую программу вставляем в новый модуль. При открытии "первой формы", или в макросе autoexec вставляем вызов функции "CheckPlaceBases". Все. Теперь программа будет проверять и по возможности восстанавливать связи с таблицами.
Как это работает:
Программа проверяет все несистемные таблицы на предмет наличия имени первого поля. Если не произошло ошибок, очевидно, что все существующие связи в порядке. Если ошибки были, проходим по таблицам еще раз, но уже с довольно громоздкой процедурой проверки. Первый цикл, вообще говоря, сделан отдельно, чтобы по возможности не сильно тормозить запуск программы в штатной ситуации.
Если найдена таблица с разрушенной связью, смотрю в таблицу известных связей (туда постепенно складываются все известные пути к БД. Удобно при перемещении файла от клиента на работу/домой и назад). Если такой таблицы нет, создаю ее. Если ни по одному известному пути нет файла с такой таблицей, запрашиваю путь к файлу у пользователя. Если файл наконец-то найден, добавляю при необходимости новый путь в таблицу путей и иду к следующей связи.
Что еще:
Работает (проверял) в A97, 2000, 2002, 2003. Для совместимости с А97 взял процедуру диалога открытия файла в исполнении К. Гетца (Ken Getz).
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 *****************
С уважением, Георгий Удалов.
[Back]
Текущий рейтинг:
0 из 5 (проголосовало:0).
Здравствуйте!
Для участия в рейтинге необходимо залогиниться на сайт.
Это сделано для того, чтобы более точно производить оценку статей (чтобы одному и тому же человеку было труднее голосовать несколько раз, портя тем самым статистику.
Эта процедура очень быстрая и, надеюсь, Вас не затруднит :).
Все мысли по поводу работы сайта всегда можно высказать на форуме!
Вход на сайт
Обсуждение статьи:
без темы BorisL
Есть одно замечание. Если "первая" форма использует в RecordSource "отсутствующие" присоединенные таблицы, то вставка ф-и CheckPlaceBases в событие Open не спасает. Акцесс успевает "проверить" связь сам. Пришлось использовать макрос AutoExec. Тестировалось на А97рус, Windows2000prof pус. А, вообще, все классно.
22.09.2004 13:12
без темы Anonimous
Честно говоря, сам я ее использую по-другому (этот способ я дал для простоты использования):
- во всех процедурах и функциях есть примерно такой код
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
, а CheckPlaceBases возвращает True, если у него все в порядке и False, если нет.
22.09.2004 20:03
без темы Гео
т.е., это у меня возвращает, здесь я это убрал зачем-то. Сейчас попробую разобраться с этим, заодно верну. А в главной форме в таком случае вызов не нужен. Да, помимо процедур, HaveError(err.number ...) вызываю во всех Form_Error и Report_Error. Как раз там подобные ошибки и происходят обычно.
22.09.2004 20:08
без темы Незнакомец
В чем может быть проблема? В базе (Аccess2000) десяток прилинкованных DBF файлов. При попытке подключения (указываю путь к файлу) выдает сообщение, что файл не содержит указанную таблицу? А вы пишите, что проверяли и все работает?
22.11.2004 12:19
А вы пишите, что проверяли Geo
Не могли бы вы выслать на
jorgen@mail.ru mdb-шку с линкованными дбф-таблицами (остальные таблицы/формы/модули и т.д. не нужны, сами dbf'ки тоже)?
23.11.2004 14:35
Минуточку... Уже не надо: geo
2 Незнакомец
Поправьте, у себя функцию
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
2 Андрей Митин
А можно как-нибудь внести исправления в исходный текст?
23.11.2004 14:58
Re:Минуточку... Уже не надо: am
geo писал:
А можно как-нибудь внести исправления в исходный текст?
Через WEB-интерфейс - пока нельзя
Руками - можно . Внес.
23.11.2004 17:49
Re:Re:Минуточку... Уже не надо: Geo
Спасибо :)
23.11.2004 17:55
УРА ЗАРАБОТАЛА! Незнакомец
Георгий, огромное спасибо. У меня все заработало. Думаю было бы неплохо выложить готовый образец БД с вашим модулем в Download. Это уже пожелание к Андрею. Уж больно часто этот вопрос возникает на разных Access форумах.
23.11.2004 18:33
Footer
