Как написать коммерческое приложение на Access

Источник: 5codelines

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

Их всего три:

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

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

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

view plain copy to clipboard print

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

До встречи!