این ضمیمه رو باز کنین - دو فایل نمونه FRONTEND و BACKEND هست
https://barnamenevis.org/attach...2&d=1278406835
BACKEND دو جدول TABLE1 و TABLE2 داره که وقتی FRONTEND رو باز میکنین بصورت خودکار ATTACH میشه.
در FRONTEND یک جدول PARAMS هست که نام دیتابیس BACKEND و فولدر اون رو ذخیره میکنه (برای دفعات بعدی دیگه سئوال نمیکنه مگر اینکه فایل BACKEND رو در محلی که قبلا بوده پیدا نکنه)
شما میتونین اسم جداولی رو که میخواین ATTACH کنین در BE_TABLES ذخیره کنین
روتین ATTACH_BACKEND در دیتابیس BACKEND تمام این جداول رو به دیتابیس اصلی ATTACH میکنه و وقتی هم که فرم اصلی بسته میشه بصورت خودکار جداول DETACH میشن
ضمنا میتونین با PASSWORD اطلاعات BACKEND رو کد کنین که در اینصورت از CONNECT دیگه ای باید استفاده کنین که همونجا نمونه اش هست
Option Compare Database
Option Explicit
Private Sub Form_Close()
Call Detach_BackEnd
End Sub
Private Sub Form_Open(Cancel As Integer)
BE_TABLES = Array("TABLE1", "TABLE2")
BE_NAME = DLookup("BENAME", "PARAMS", "ID=1")
BE_FOLDER = DLookup("BEFOLDER", "PARAMS", "ID=1")
Do While Dir(BE_FOLDER & "\" & BE_NAME) = ""
BE_FOLDER = BrowseFolder("لطفا مسیر فایل اطلاعات را مشخص کنید" & vbCrLf & BE_NAME)
If BE_FOLDER = "" Then
V = MsgBox("مسیر فایل اطلاعات باید مشخص شود" & vbCrLf & "دوباره برنامه را اجرا کنید", vbOKOnly + vbMsgBoxRtlReading + vbCritical, "")
DoCmd.Quit acQuitSaveNone
End If
Loop
DoCmd.RunSQL ("UPDATE PARAMS SET BEFOLDER='" & BE_FOLDER & "' WHERE ID=1")
Call Attach_BackEnd
End Sub
Private Sub Attach_BackEnd()
Dim TDF As TableDef
Dim I As Integer
For I = 0 To UBound(BE_TABLES)
Dim T As TableDef
For Each T In CurrentDb.TableDefs
If T.Name = BE_TABLES(I) Then
CurrentDb.TableDefs.Delete (BE_TABLES(I))
CurrentDb.TableDefs.Refresh
Exit For
End If
Next
Set TDF = CurrentDb.CreateTableDef(BE_TABLES(I))
TDF.SourceTableName = BE_TABLES(I)
' TDF.Connect = "MS Access;PWD=**********;DATABASE=" & BE_FOLDER & "\" & BE_NAME
TDF.Connect = "MS Access;DATABASE=" & BE_FOLDER & "\" & BE_NAME
CurrentDb.TableDefs.Append TDF
Next
CurrentDb.TableDefs.Refresh
End Sub
Private Sub Detach_BackEnd()
Dim TDF As TableDef
Dim I As Integer
For I = 0 To UBound(BE_TABLES)
CurrentDb.TableDefs.Delete (BE_TABLES(I))
Next
CurrentDb.TableDefs.Refresh
End Sub
کد جستجوی محل دیتابیس رو کس دیگه ای نوشته :
Option Compare Database
Option Explicit
'This code was originally written by Terry Kreft.
'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.
'
'Code courtesy of
'Terry Kreft
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Const BIF_RETURNONLYFSDIRS = &H1
Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer
With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
پاسخ با نقل قول