5 строк кода

Как писать приложения на MS Access

Как создать ссылки на таблицы

Комментариев нет

Хочу представить Вам функции, без которых нормальная жизнь программы на 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 рассылку или добавить в ЖЖ друзья.

Written by Сергей Скоков

Май 6th, 2011 at 11:41 дп

Leave a Reply