جایگزین کردن جداول(فوری)

[azadich]

با سلام خدمت اساتید محترم،من از دستور زیر برای جایگزین کردن جداولم استفاده می کنم حال اگر بخوام با زدن همین دکمه بیش از یک جدول جایگزین بشه چه تغییری در کد لازم است؟لطف کنید کد را برای بیش از یک جدول اصلاح فرمایید.متشکر
Private Sub Command60_Click()
Dim tdf As String
tdf = "Students"
If tdf = "" Then Exit Sub
If RepalceTable(tdf) Then
MsgBox "æÑæÏ ÇØáÇÚÇÊ ÇäÌÇã ÔÏ", , "íÛÇã"
End If

End Sub

[Abbas Amiri]

با سلام خدمت اساتید محترم،من از دستور زیر برای جایگزین کردن جداولم استفاده می کنم حال اگر بخوام با زدن همین دکمه بیش از یک جدول جایگزین بشه چه تغییری در کد لازم است؟لطف کنید کد را برای بیش از یک جدول اصلاح فرمایید.متشکر
Private Sub Command60_Click()
Dim tdf As String
tdf = "Students"
If tdf = "" Then Exit Sub
If RepalceTable(tdf) Then
MsgBox "æÑæÏ ÇØáÇÚÇÊ ÇäÌÇã ÔÏ", , "íÛÇã"
End If

End Sub

تابع RepalceTable کجاست ؟ آنرا هم نمایش بدید . مشخص نکرده اید چه جدولهایی بایستی جایگزین شوند

[azadich]

الان فقط اطلاعات تیبل student جایگزین میشه.حال میخوام چند جدول با هم جایگزین شود مثلا student و status و teacher

[azadich]

تابع RepalceTable کجاست ؟ آنرا هم نمایش بدید . مشخص نکرده اید چه جدولهایی بایستی جایگزین شوند
این هم تابع:
Function RepalceTable(TableName As String) As Boolean
On Error GoTo ErrImport
Dim tdf As TableDef
Dim sPath As String
sPath = fFileDialogAns(msoFileDialogFilePicker, "", "", "Access Database", "*.adp; *.ade")
If sPath = "" Then Exit Function
DoCmd.TransferDatabase acImport, "Microsoft Access", sPath, acTable, TableName, "tmpTableReplacement"
DoCmd.DeleteObject acTable, TableName
CurrentDb.TableDefs("tmpTableReplacement").name = TableName
RepalceTable = True
Exit Function
ErrImport:
If err.number = 7874 Then
If MsgBox("ÌÏæá ãæÑÏ äÙÑ ÏÑ ÝÇíá ÌÇÑí íÇÝÊ äÔÏ. Èå ÏíÊÇÈíÓ ÇÖÇÝå ÔæÏ¿", vbQuestion + vbYesNo, "") = vbNo Then
DoCmd.DeleteObject acTable, "tmpTableReplacement"
Else
CurrentDb.TableDefs("tmpTableReplacement").name = TableName
End If
ElseIf err.number = 3011 Then
MsgBox "ÌÏæá ãæÑÏ äÙÑ ÏÑ ÝÇíá ãÈÏÇ íÇÝÊ äÔÏ."
Else
MsgBox err.number & " , " & err.Description
End If
End Function

[Abbas Amiri]

برای انجام مورد درخواستی کمی تغییر در کدها باید انجام شود .

ابتدا

Private Sub Command60_Click()
Dim tdf As String
tdf = "Students,Teacher,status "
If tdf = "" Then Exit Sub
If RepalceTables(tdf) Then
MsgBox "?N~?I" C,?a'C,U'C,E^ C,a"I`C,a~ O^I"", , "?i'U^C,a~"
End If
End Sub


وهم چنین تابع


Function RepalceTables(TableNames As String) As Boolean
On Error GoTo ErrImport
Dim tdf As TableDef
Dim i As Integer, NumTables As Integer, tdfName As String
If Len(TableNames) = 0 Then Exit Function
sPath = fFileDialogAns(msoFileDialogFilePicker, "", "", "Access Database", "*.mdb;*.accdb;*.adp; *.ade")
If sPath = "" Then Exit Function
NumTables = UBound(Split(TableNames, ","))
For i = 0 To NumTables
tdfName = Split(TableNames, ",")(i)
DoCmd.TransferDatabase acImport, "Microsoft Access", sPath, acTable, tdfName, "tmpTableReplacement"
DoCmd.DeleteObject acTable, tdfName
CurrentDb.TableDefs("tmpTableReplacement").Name = tdfName
Next
RepalceTable = True
Exit Function
ErrImport:
If Err.Number = 7874 Then
If MsgBox("ÌÏæá ãæÑÏ äÙÑ ÏÑ ÝÇíá ÌÇÑí íÇÝÊ äÔÏ. Èå ÏíÊÇÈíÓ ÇÖÇÝå ÔæÏ¿", vbQuestion + vbYesNo, "") = vbNo Then
DoCmd.DeleteObject acTable, "tmpTableReplacement"
Else
CurrentDb.TableDefs("tmpTableReplacement").Name = TableName
End If
ElseIf Err.Number = 3011 Then
MsgBox "ÌÏæá ãæÑÏ äÙÑ ÏÑ ÝÇíá ãÈÏÇ íÇÝÊ äÔÏ."
Else
MsgBox Err.Number & " , " & Err.Description
End If
End Function

[azadich]

خیلی ببخشید حالا پنجره برای انتخاب مسیر باز نمیشه آیا این قسمت هم باید تغییراتی کنه؟

Public Function fFileDialogAns(dlgType As MsoFileDialogType, sPath As String, sFileName As String, _
Optional sFilterDesc As String = "", Optional sFilterExtention As String = "") As String
Dim dlg As FileDialog
Dim varSelItems As Variant
Dim k As Integer, s As String, s2 As String, strOpenFile As String
fFileDialogAns = ""
Set dlg = Application.FileDialog(dlgType)
If dlgType = msoFileDialogSaveAs Then
dlg.Title = "ÐÎíÑå ÝÇíá"
dlg.InitialFileName = sPath & "\" & sFileName
dlg.ButtonName = "ÐÎíÑå"
ElseIf dlgType = msoFileDialogFilePicker Then
dlg.Filters.Clear
dlg.Title = "ÇäÊÎÇÈ ÝÇíá áæÏÑ"
dlg.Filters.add sFilterDesc, sFilterExtention, 1
dlg.InitialFileName = sPath
dlg.ButtonName = "ÇäÊÎÇÈ"
Else
dlg.Title = "ÇäÊÎÇÈ æÔå"
dlg.InitialFileName = sPath & "\"
End If
If dlg.Show = True Then
Else
Set dlg = Nothing
Exit Function
End If
For Each varSelItems In dlg.SelectedItems
sPath = varSelItems
Next
Set dlg = Nothing
If dlgType = msoFileDialogFilePicker Or dlgType = msoFileDialogFolderPicker Then
fFileDialogAns = sPath
Exit Function
End If
k = InStr(sPath, ".")
s = Right(sPath, Len(sPath) - k)
k = InStr(sFileName, ".")
s2 = Right(sFileName, Len(sFileName) - k)
If s <> s2 Then Exit Function
fFileDialogAns = sPath
End Function

[azadich]

ا ساتید محترم لطفا این کد را هم اصلاح فرمایید

[azadich]

لطف کنید رو نمونه اصلاح فرمایید...متشکر

[Abbas Amiri]

لطف کنید رو نمونه اصلاح فرمایید...متشکر
این خط کد زیر را جایگزین کنید:

Function RepalceTable(TableNames As String) As Boolean