|
Доброго времени суток, Посетитель!
|
|
|
|
|
|
|
|
|
вид форума:
|
| |
|
|
| | не пинайте сильно плиз((
ну не догоняю я((
на русимпорте(вроде) взял код по автоматической привязке таблиц к основной базе
Option Explicit
Dim tbl As DAO.TableDef
Public retval As Boolean
Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
Public Function CheckPlaceBases()
' Поиск файлов со связанными таблицами
Dim sp, sf As String
Dim rs As DAO.Recordset
Dim strFullPath As String
Dim intPos As Integer
' Проверяю все таблицы. Не знаю способа лучше перебора всех таблиц
On Error Resume Next
For Each tbl In CurrentDb.TableDefs
If Left(tbl.Name, 4) <> "MSys" Then
If tbl.Fields(0).Name = "" Then
End If
End If
If Err.Number <> 0 Then
Exit For ' Возможно, таблица не найдена, шагаем дальше
End If
Next
If Err.Number = 0 Then Exit Function ' Все в порядке
strFullPath = CurrentDb.Name
' Ищем последний слэш в полном адресе к текущей базе
intPos = InStrRev(strFullPath, "\")
If intPos > 0 Then
strFullPath = Left(strFullPath, intPos)
End If
' Спрашиваю, выполнить ли поиск? Если нет, выхожу из программы
If MsgBox("Не могу восстановить подключение к базе данных." & Chr(10) & _
"Возможно, файл БД был перемещен." & Chr(10) & _
"Попробовать найти его?", vbYesNo, "Ошибка подключения к базе") = vbYes Then
' Подключаю таблицу известных путей. Если ее нет, создаю
Err.Clear
Set rs = CurrentDb.OpenRecordset("сПутиКтаблицам")
If Err.Number <> 0 Then
CurrentDb.Execute "create table сПутиКтаблицам (ПутьКтаблице text(250))"
Set rs = CurrentDb.OpenRecordset("сПутиКтаблицам")
End If
For Each tbl In CurrentDb.TableDefs
On Error Resume Next
If tbl.Fields(0).Name = "" Then
End If ' Если произойдет ошибка - возможно, таблица не подключена
If Err.Number <> 0 And Len(tbl.Connect) Then
' Проверяю наличие таблицы по последним известным путям.
rs.MoveFirst ' Здесь м.б. ошибка, если нет текущей записи
On Error GoTo 0
Do Until rs.EOF
' Если таблица подцепилась, прекращаю перебор файлов и перехожу к следующей
If TryConnectToTable(rs!ПутьКтаблице) Then Exit Do
rs.MoveNext
Loop
If rs.EOF Then ' Если находимся в конце rs, то либо он пуст, _
' либо файлы не найдены, либо ни в одном файле таблицы нет
' По последним известным путям таблица найдена не была,
' предлагаю найти файл самостоятельно.
Do
sp = ""
If sf = "" Then
sf = ahtAddFilterItem(sf, "Файлы Microsoft Access", "*.mdb;*.mde;*.mda")
sf = ahtAddFilterItem(sf, "Все файлы", "*.*")
If MsgBox("Не могу восстановить связь с таблицей " & tbl.Name & _
" по известным путям." & Chr(10) & _
"Попробуете найти файл с таблицей самостоятельно?", _
vbYesNo) = vbYes Then
sp = GetOpenFile(strFullPath, _
varTitleForDialog:="Выберите файл, содержащий " & _
tbl.Name, strFilter:=sf, lngFlags:=0)
Else
Exit Do
End If
Else
If MsgBox("В этом файле таблица " & tbl.Name & _
" не найдена." & Chr(10) & _
"Хотите выбрать другой файл?", vbYesNo) = vbYes Then
sp = GetOpenFile(varTitleForDialog:="Выберите файл, содержащий " & _
tbl.Name, strFilter:=sf, lngFlags:=0)
Else
Exit Do
End If
End If
Loop While (TryConnectToTable(sp) = False)
On Error Resume Next
If tbl.Fields(0).Name <> "" Then
' Произойдет ошибка, если таблица не была подключена
End If
If Err.Number <> 0 Then
' Если файл не найден пользователем,
'сообщаю об этом пользователю и продолжаю цикл
MsgBox "Не все связи восстановлены!" & Chr(10) & _
"В работе программы возможны ошибки." & _
"Рекомендуется закрыть программу и обратиться к разработчику!"
Else
' Если файл найден пользователем (не в rs), добавляю его в rs
rs.AddNew
rs!ПутьКтаблице = sp
rs.Update
End If
On Error GoTo 0
End If
End If
On Error GoTo 0
Next tbl
Set tbl = Nothing
On Error Resume Next
rs.Close
On Error GoTo 0
Set rs = Nothing
Else
MsgBox "Не все связи восстановлены!" & Chr(10) & _
"В работе программы возможны ошибки." & _
"Рекомендуется закрыть программу и обратиться к разработчику!"
End If
End Function
Private Function TryConnectToTable(ByVal strPath As String) As Boolean
Dim s As String
On Error Resume Next
If Len(Dir(strPath)) > 0 Then ' Файл есть, пробую подцепить таблицу
s = tbl.Connect
tbl.Connect = Left(s, InStr(s, ";DATABASE=") + 9) & strPath
tbl.RefreshLink ' RefreshLink возвратит ошибку, если таблицы в файле нет
If Err.Number <> 0 And InStr(strPath, "\") Then
' Попробуем, на случай, если это не .mdb файл, указать здесь имя папки без файла
Err.Clear
tbl.Connect = Left(tbl.Connect, InStrRev(tbl.Connect, "\"))
tbl.RefreshLink
End If
TryConnectToTable = Not (Err.Number <> 0)
If Err.Number <> 0 Then tbl.Connect = s
End If
End Function
Public Function InStrRev(StringSource As String, StringTarget As String) As Integer
Dim t As Long
Do
t = InStr(t + 1, StringSource, StringTarget)
Loop While t > 0 And InStr(t + 1, StringSource, StringTarget) > 0
InStrRev = t
End Function
'***************** Code Start **************
'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
Public Function GetOpenFile(Optional varDirectory As String, _
Optional varTitleForDialog As String, _
Optional strFilter As String, _
Optional lngFlags As Long) As String
Dim varFileName As Variant
' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.
If lngFlags Then _
lngFlags = ahtOFN_FILEMUSTEXIST Or _
ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If strFilter = "" Then _
strFilter = ahtAddFilterItem(strFilter, _
"All files (*.*)", "*.*")
' Now actually call to get the file name.
varFileName = ahtCommonFileOpenSave( _
OpenFile:=True, _
InitialDir:=varDirectory, _
Filter:=strFilter, _
flags:=lngFlags, _
DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
varFileName = TrimNull(varFileName)
End If
GetOpenFile = varFileName
End Function
Function ahtCommonFileOpenSave( _
Optional ByRef flags As Variant, _
Optional ByVal InitialDir As Variant, _
Optional ByVal Filter As Variant, _
Optional ByVal FilterIndex As Variant, _
Optional ByVal DefaultExt As Variant, _
Optional ByVal FileName As Variant, _
Optional ByVal DialogTitle As Variant, _
Optional ByVal hwnd As Variant, _
Optional ByVal OpenFile As Variant) As Variant
' This is the entry point you'll use to call the common
' file open/save dialog. The parameters are listed
' below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFilename As String
Dim strFileTitle As String
Dim fResult As Boolean ' Give the dialog a caption title.
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(Filter) Then Filter = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(flags) Then flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
' Allocate string space for the returned strings.
strFilename = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With OFN
.lStructSize = Len(OFN)
.hwndOwner = hwnd
.strFilter = Filter
.nFilterIndex = FilterIndex
.strFile = strFilename
.nMaxFile = Len(strFilename)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = DialogTitle
.flags = flags
.strDefExt = DefaultExt
.strInitialDir = InitialDir
' Didn't think most people would want to deal with
' these options.
.hInstance = 0
.strCustomFilter = ""
.nMaxCustFilter = 0
.lpfnHook = 0
'New for NT 4.0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
End With
' This will pass the desired data structure to the
' Windows API, which will in turn it uses to display
' the Open/Save As Dialog.
If OpenFile Then
fResult = aht_apiGetOpenFileName(OFN)
Else
fResult = aht_apiGetSaveFileName(OFN)
End If
' The function call filled in the strFileTitle member
' of the structure. You'll have to write special code
' to retrieve that if you're interested.
If fResult Then
' You might care to check the Flags member of the
' structure to get information about the chosen file.
' In this example, if you bothered to pass in a
' value for Flags, we'll fill it in with the outgoing
' Flags value.
If Not IsMissing(flags) Then flags = OFN.flags
ahtCommonFileOpenSave = TrimNull(OFN.strFile)
Else
ahtCommonFileOpenSave = vbNullString
End If
End Function
Function ahtAddFilterItem(strFilter As String, _
strDescription As String, Optional varItem As Variant) As String
' Tack a new chunk onto the file filter.
' That is, take the old value, stick onto it the description,
' (like "Databases"), a null character, the skeleton
' (like "*.mdb;*.mda") and a final null character.
If IsMissing(varItem) Then varItem = "*.*"
ahtAddFilterItem = strFilter & _
strDescription & vbNullChar & _
varItem & vbNullChar
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
TrimNull = Left(strItem, intPos - 1)
Else
TrimNull = strItem
End If
End Function
'************** Code End *****************
|
так вот как вызвать эту функцию CheckPlaceBases на событие в форме? Например на нажатие кнопки... | |
| |
| |
| |
|
|
| | офигеть не встать......... | |
| |
| |
| |
|
|
| | почему?
работает отлично
просто я базу таскаю с работы домой, запарился прописывать таблицы каждый раз
осталось только чтобы во время загрузки первой формы срабатывал код
вот и спросил, как это сделать... | |
| |
| |
| |
|
|
| | Офигеть, потому как много написано.
Я тоже автоматом "подцепляю", но так много писать не стал.
Проверяю имеются ли связанные таблицы в текущей базе, если нет - прошу указать место нахождения и всё...
Дальше они из указанного файла MDB - автоматом линкуются.
Так же можно указать несколько MDB в таблице - которые следует подключить.
Если при подключении необходимо изменить имена таблиц тогда в таблику в два столбца пишуться линкуемые таблицы со старыми и новыми именами.
Вобщем конечно , раз код работает - пусть себе работает. | |
| |
| |
| |
|
|
| | ну фик знает
час, а выложи свой код тогда
я просто искал разные варианты, этот показался мне подходящим...а уж сколько там в коде наворочено, разбираться мне пока еще рано | |
| |
| |
| |
|
|
| | Извини...........
Сейчас я на работе, и тута у меня rintime -версия. Ничего нельзя в ней править - только пользоваться........
Я вырежу его (код-вариант) и заметку сварганю на всеобщее обозрение - вот тогда ............... | |
| |
| |
| |
 25 Кб. |
|
| | Например так. См. аттач
и еще вот это посмотрите:
http://hiprog.com/index.php?option=com_content&task=view&id=416 | |
| |
| |
| |
49 Кб. |
|
| | не получается osmor! ((
Compile error:
Expected variable or procedure, not module
что не сделал я?
я в самом начале на кнопку повесил функцию, она не заработала
помучившись, решил на форуме спросить | |
| |
| |
| |
|
|
| | ну почему не работает, а?
подскажите плиз(( | |
| |
| |
| |
|
|
| | Вы назвали модуль так же как и функцию.
Переименуйте что нибуть. Лучше модуль | |
| |
| | |
|
HiProg.com - Технологии программирования
|
