5 строк кода

Хочу представить Вам функции, без которых нормальная жизнь программы на MS Access не возможно.

Их всего три:

• CM_LT_AddAllExt() — добавляет в текущую базу ссылки на таблицы из mdb файла
• CM_LT_AddAllExt_ODBC() — добавляет в текущую базу ссылки на ODBC таблицы на сервере
• CM_LT_DelAll() — удаляет таблицы-ссылки из текущей базы

Они позволяют создать в интерфейсной базе ссылки на таблицы из базы с данным. У меня они запускаются каждый раз при запуске. Написаны они давным давно, но полезны до сих пор.

Текст функций:

Public Function CM_LT_AddAllExt(ByVal stPathToBase As String) As Long
' <Скоков С.А.> создана: 2004-02-05
' подлинковывает все таблицы из указанной базы
' проверяет существует ли подлинковываемая таблица в текущей как ссылка, то обновляется строка подключения.
' если же в тек. базе есть таблица с таким именем (не ссылка), то подлинковываемая таблица пропускается
' т.о. перед вызовом этой функции удалять линкованные таблицы не нужно
' вход: stPathToBase - путь и имя базы
' выход: количество не подлинкованных таблиц, в случае ошибки возвращает -1

On Error GoTo Err_
    CM_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

    '-- коннектимся к базе
    Set db = OpenDatabase(stPathToBase)

    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
                    tdfsCur(stNameTbl).RefreshLink
                Else
                    Debug.Print "CM_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

    CM_LT_AddAllExt = lCountNotLinket
Exit_:
    Exit Function

Err_:
    CM_LT_AddAllExt = -1
	Err.Raise Err.Number, "CM_LT_AddAllExt()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию

    Resume Exit_
End Function

Private Function SerchStrInMas(ByRef masStr() As String, ByRef SerchStr As String) As Long
' <Скоков С.А.> создана: 2004-02-05

' Поиск строки в строковом массиве
' вход: 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

Public Function CM_LT_AddAllExt_ODBC(ByVal stConnectStr As String) As Long
' <Кулага С.Ю.> создана: 2006-10-12

'   подлинковывает все таблицы из указанной базы
'   проверяет существует ли подлинковываемая таблица в текущей как ссылка, то удаляет.
'   если же это является таблицей, то подлинковываемая таблица пропускается
'   т.е. перед вызовом этой функции удалять линкованные таблицы не нужно, он удалить необходимые сама
' вход: stConnectStr - строка подключения ADO
' выход: количество не подлинкованных таблиц, в случае ошибки возвращает -1

On Error GoTo Err_
    CM_LT_AddAllExt_ODBC = 0

    Dim bIsSysOrLink As Boolean
    Dim stNameTbl As String
    Dim tdf As TableDef
    Dim lCountNotLinket As Long ' количество не подлинкованных таблиц
    Dim cnn As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim stConnectTbl As String
    Dim dbCur As DAO.Database
    Dim tdfNew As DAO.TableDef
    Dim tdfsCur As DAO.TableDefs

    stConnectTbl = "ODBC;" & stConnectStr
    Set dbCur = CurrentDb
    Set tdfsCur = dbCur.TableDefs

    ' делаем масив таблиц в текущей базе
    Dim masNameTbl() As String
    Dim i As Long

    ReDim masNameTbl(tdfsCur.count - 1)
    i = 0
    For Each tdf In tdfsCur
        masNameTbl(i) = tdf.Name
        i = i + 1
    Next tdf

    ' коннектимся к базе
    Set cnn = New ADODB.Connection
    cnn.Open (stConnectStr)
    Set rst = cnn.OpenSchema(adSchemaTables)

    lCountNotLinket = 0
    ' линкуем
    Do While Not rst.EOF
        stNameTbl = rst("TABLE_NAME")
        ' если такая таблица существует в текущей базе
        If SerchStrInMas(masNameTbl, stNameTbl) <> -1 Then
            ' то проверяем линкованая ли? иначе пропусаем эту таблицу и переходим на следующую
            If (tdfsCur(stNameTbl).Attributes And (dbAttachedTable + dbAttachedODBC)) Then
                '-- обновляем путь к бд
                tdfsCur(stNameTbl).Connect = stConnectTbl
                tdfsCur(stNameTbl).RefreshLink
            Else
                Debug.Print "CM_LT_AddAllExt_ODBC(), пропущена таблица:", stNameTbl
                lCountNotLinket = lCountNotLinket + 1
            End If
        Else
			'-- не существует - то линкуем
            Set tdfNew = dbCur.CreateTableDef(stNameTbl)
            tdfNew.SourceTableName = stNameTbl
            tdfNew.Connect = stConnectTbl
            tdfsCur.Append tdfNew
        End If
        rst.MoveNext
    Loop

    tdfsCur.Refresh
    Set tdfsCur = Nothing
    Set dbCur = Nothing

    rst.Close
    cnn.Close
    CM_LT_AddAllExt_ODBC = lCountNotLinket

Exit_:
    Exit Function

Err_:
    Err.Raise Err.Number, "CM_LT_AddAllExt_ODBC()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию
    CM_LT_AddAllExt_ODBC = -1
    Resume Exit_
End Function

Public Function CM_LT_DelAll() As Boolean
' <Скоков С.А.> создана: 2003-12-12

' удаляет все связаные таблицы в текущей базе

On Error GoTo Err_

    Dim tdf As TableDef
    Dim db As Database
    Dim bIsAttached As Boolean

    Set db = CurrentDb

    For Each tdf In db.TableDefs
        bIsAttached = (tdf.Attributes And dbAttachedODBC) _
                Or (tdf.Attributes And dbAttachedTable) ' присеоединенная таблица обыкновенная или ODBC

        If bIsAttached Then ' удаляем только прилинкованные
            DoCmd.DeleteObject acTable, tdf.Name
        End If
    Next

    Set db = Nothing
    CM_LT_DelAll = True
Exit_:
    Exit Function
Err_:
    CM_LT_DelAll = False

	Err.Raise Err.Number, "CM_LT_DelAll()->" & Err.Source, Err.Description '-- передаем ошибку в вызвавшую функцию
    Resume Exit_
End Function

До встречи!

(с) Скоков Сергей

Подписаться на: RSS или e-mail рассылку или добавить в ЖЖ друзья.