Очень много нагугли, но так е разобрался. Задача:
Имеется пустая(без таблиц) база с кодом. Рядом с ней имеется другая база.
Необходимо связать программно так как делается вручную через Файл - Внешние данные - Связать с таблицими
Нашел, вроде, подходящий код, но вылетает на выделенной строке.
Что не так?
Option Compare Database
Код:
Public Function AutoExec()
Dim ST
VC_LT_AddAllExt CurrentProject.Path
End Function
Public Function VC_LT_AddAllExt(ByVal stPathToBase As String) As Long
' создана: 2004-02-05
' изменена: 2007-04-02
' подлинковывает все таблицы из указанной базы
' проверяет существует ли подлинковываемая таблица в текущей как ссылка, то обновляется строка подключения.
' если же в тек. базе есть таблица с таким именем (не ссылка), то подлинковываемая таблица пропускается
' т.о. перед вызовом этой функции удалять линкованные таблицы не нужно
' вход: stPathToBase - путь и имя базы
' выход: количество не подлинкованных таблиц, в случае ошибки возвращает -1
On Error GoTo Err_
VC_LT_AddAllExt = 0
Dim tdf As TableDef
Dim db As Database
Dim bIsSysOrLink As Boolean
Dim stNameTbl As String
Dim lCountNotLinket As Long ' количество не подлинкованных таблиц
Dim stConnect As String
Dim dbCur As DAO.Database
Dim tdfNew As DAO.TableDef
Dim tdfsCur As DAO.TableDefs
stConnect = ";DATABASE=" & stPathToBase
Set dbCur = CurrentDb
Set tdfsCur = dbCur.TableDefs
'-- делаем масив таблиц в текущей базе
Dim masNameTbl() As String
Dim i As Long
tdfsCur.Refresh
ReDim masNameTbl(tdfsCur.Count - 1)
i = 0
For Each tdf In tdfsCur
masNameTbl(i) = tdf.Name
i = i + 1
Next tdf
Dim fle, FL
fle = Dir(stPathToBase & "\*.mdb")
Do
If fle <> "Ломалка_ASр.mdb" Then FL = stPathToBase & "\" & fle
fle = Dir
Loop While fle <> ""
'-- коннектимся к базе
Set db = OpenDatabase(FL)
lCountNotLinket = 0
'-- линкуем
For Each tdf In db.TableDefs
bIsSysOrLink = (tdf.Attributes And dbSystemObject) Or _
(tdf.Attributes And dbHiddenObject) _
Or (tdf.Attributes And dbAttachedTable) ' системная или присеоединенная ли?
If Not bIsSysOrLink Then ' если не то что выше, то можно делать линк
stNameTbl = tdf.Name
'-- если такая таблица существует в текущей базе
If SerchStrInMas(masNameTbl, stNameTbl) <> -1 Then
'-- то проверяем подлинкованая ли? иначе пропусаем эту таблицу и переходим на следующую
If (tdfsCur(stNameTbl).Attributes And dbAttachedTable) Then
'-- обновляем путь к бд
tdfsCur(stNameTbl).Connect = stConnect
Else
Debug.Print "VC_LT_AddAllExt(), пропущена таблица:", stNameTbl
lCountNotLinket = lCountNotLinket + 1
End If
Else
'-- не существует - то линкуем
Set tdfNew = dbCur.CreateTableDef(stNameTbl)
tdfNew.SourceTableName = stNameTbl
tdfNew.Connect = stConnect
tdfsCur.Append tdfNew
End If
End If
Next tdf
db.Close
Set db = Nothing
tdfsCur.Refresh
Set tdfsCur = Nothing
Set dbCur = Nothing
VC_LT_AddAllExt = lCountNotLinket
Exit_:
Exit Function
Err_:
VC_LT_AddAllExt = -1
Debug.Print Date, Time, "VC_LT_AddAllExt", Err.Number, Err.Description
MsgBox "Во время работы возникла ошибка! Обратитесь к разработчику.", vbCritical
Resume Exit_
Resume
End Function
Private Function SerchStrInMas(ByRef masStr() As String, ByRef SerchStr As String) As Long
' создана: 2004-02-05
' изменена: 2004-09-29
' Поиск строки в строковом масиве
' вход: masStr - масив строк
' SerchStr - искомая строка
' выход:
' номер элемента масива, в котором была найдена подстрока SerchStr, иначе -1 (когде нет совпадений)
' при ошибке возвращает -1
On Error GoTo Err_
Dim i As Long
SerchStrInMas = -1
For i = LBound(masStr) To UBound(masStr)
If masStr(i) = SerchStr Then
SerchStrInMas = i
Exit For
End If
Next i
Exit_:
Exit Function
Err_:
SerchStrInMas = -1
Resume Exit_
End Function
В AutoExec это уже я сам пытался