Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Access
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 11.11.2011, 16:43   #1
alex77755
Форумчанин
 
Аватар для alex77755
 
Регистрация: 14.02.2009
Сообщений: 753
По умолчанию Внешние данные программно

Очень много нагугли, но так е разобрался. Задача:
Имеется пустая(без таблиц) база с кодом. Рядом с ней имеется другая база.
Необходимо связать программно так как делается вручную через Файл - Внешние данные - Связать с таблицими
Нашел, вроде, подходящий код, но вылетает на выделенной строке.
Что не так?
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 это уже я сам пытался
помогу решить контрольные VB6, VBA (недорого)
Alex77755@mail.ru
alex77755 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Программно занести данные в реестр Nexus2116 Общие вопросы Delphi 1 05.11.2010 21:56
Внешние данные и доступ к листу Евгений_12 Microsoft Office Excel 4 07.06.2010 12:53
Excel и внешние данные Евгений_12 Microsoft Office Excel 0 06.06.2010 09:48
Как программно прочитать данные из едита другой программы xakkkkker Общие вопросы Delphi 1 15.03.2009 12:13
Программно читать данные из БД Access Заяц Microsoft Office Access 4 10.06.2007 00:46