Back up for table

[هادی2020]

چطور می توان از جدول ها فقط پشتیبان گرفت .به خاطر کمی وقتم از شما کمک می خواهم اما
در صورتی که کمک نکردین خودم دست به کار می شم و جواب را براتون ارسال میکنم
می خواهم این جدول را در یک پروژه که ابتدا آن را می سازیم سپس جدول را به داخل آن می ریزیم. اگر راه حل دیگری دارید بیان کنید
لطفا کاملش کنید
Option Compare Database
' Include following in Declarations section of module.
Dim appAccess As Access.Application, stname As String
Public Function backup()
Dim e As String, stmsg As String, X As Integer, er As String, strinput As String
On Error GoTo hadi
'Application.CreateAccessProject
'DoCmd.CopyDatabaseFile databasefilename:=e, overWriteExistingFile:=True, DisconnectAllUsers:=True
'DoCmd.TransferDatabase acExport, "Microsoft Access", _
' e, acTable, "Makan_Darmani", "hadi"
'NewAccessProject e
stmsg = "ÏÑ ÕæÑÊí ßå ÈÑäÇãå íÇ ÝÑãí ÈÇÒ ãí ÈÇÔÏ" & vbCrLf
stmsg = stmsg + "ÈÑÇí ÇÍÊíÇØ ÈíÔÊÑ ÇÒ Âä ÎÇÑÌ ÔæíÏ" & vbCrLf
stmsg = stmsg + "ÂíÇ ÇÒ ÈÑäÇãå åÇ ÎÇÑÌ æ ÂãÇÏå ÇíÏ"
X = MsgBox(stmsg, vbYesNo + vbExclamation + vbDefaultButton1, "zamany_2020@yahoo.com")

If X = vbNo Then Exit Function
1:
Err.Clear: X = 0
strinput = Date$
X = InStr(strinput, "/")
If X <> 0 Then strinput = Replace(strinput, "/", "-")
X = InStr(strinput, "\")
If X <> 0 Then strinput = Replace(strinput, "\", "-")
X = InStr(strinput, "?")
If X <> 0 Then strinput = Replace(strinput, "?", "-")
X = InStr(strinput, ":")
If X <> 0 Then strinput = Replace(strinput, ":", "-")
X = InStr(strinput, str(34))
If X <> 0 Then strinput = Replace(strinput, str(34), "-")
X = InStr(strinput, "*")
If X <> 0 Then strinput = Replace(strinput, "*", "-")
X = InStr(strinput, str(92))
If X <> 0 Then strinput = Replace(strinput, str(92), "-")
X = InStr(strinput, "|")
If X <> 0 Then strinput = Replace(strinput, "|", "-")
X = InStr(strinput, "<")
If X <> 0 Then strinput = Replace(strinput, "<", "-")
X = InStr(strinput, ">")
If X <> 0 Then strinput = Replace(strinput, ">", "-")
e = InputBox("&#228;&#199;&#227; &#221;&#199;&#237;&#225; �&#212;&#202;&#237;&#200;&#199;&#228; &#209;&#199; &#230;&#199;&#209;&#207; &#223;&#228;&#237;&#207;", "zamany_2020@yahoo.com", strinput)
If e = "" Then Exit Function
' 34" 42* 47/ 58: 60< 62> 92\
X = 0
X = InStr(e, "*"): If X <> 0 Then GoTo hadi
X = InStr(e, str(34)): If X <> 0 Then GoTo hadi
X = InStr(e, "/"): If X <> 0 Then GoTo hadi
X = InStr(e, "\"): If X <> 0 Then GoTo hadi
X = InStr(e, ":"): If X <> 0 Then GoTo hadi
X = InStr(e, "?"): If X <> 0 Then GoTo hadi
X = InStr(e, "<"): If X <> 0 Then GoTo hadi
X = InStr(e, ">"): If X <> 0 Then GoTo hadi
X = InStr(e, "|"): If X <> 0 Then GoTo hadi
X = InStr(e, str(92)): If X <> 0 Then GoTo hadi

stname = Application.CurrentProject.Path + "\" + e + ".mdb"
Call NewAccessDatabase
DoCmd.TransferDatabase acExport, "Microsoft Access", stname, acTable, _
"Makan_Darmani", "Makan_Darmani"
DoCmd.TransferDatabase acExport, "Microsoft Access", stname, acTable, _
"Moshakhasat", "Moshakhasat"
Exit Function
hadi:
er = "&#228;&#199;&#227; &#230;&#199;&#209;&#207; &#212;&#207;&#229; &#227;&#212;&#223;&#225; &#207;&#199;&#209;&#207; &#225;&#216;&#221;&#199; &#228;&#199;&#227; &#207;&#237;�&#209;&#237;" & vbCrLf
er = er + "&#209;&#199; &#230;&#199;&#209;&#207; &#223;&#228;&#237;&#207; "
MsgBox er, vbCritical, "zamany_2020@yahoo.com"
GoTo 1
End Function

Sub NewAccessDatabase()
Dim dbs As Object, tdf As Object, fld As Variant
Dim appAccess As Access.Application
'Dim strDB As String
Const DB_Text As Long = 10
Const FldLen As Integer = 40
On Error GoTo hadi
Err.Clear
' Initialize string to database path.

'' strDB = "C:\My Documents\Newdb.mdb"
' Create new instance of Microsoft Access.
Set appAccess = CreateObject("Access.Application.10")

' Open database in Microsoft Access window.
appAccess.NewCurrentDatabase stname
' Get Database object variable.
Set dbs = appAccess.CurrentDb
' Create new table.
''Set tdf = dbs.CreateTableDef("Makan_Darmani")
' Create field in new table.
''Set fld = tdf. _
'' CreateField("CompanyName", DB_Text, FldLen)
' Append Field and TableDef objects.
''tdf.Fields.Append fld
''dbs.TableDefs.Append tdf
Set appAccess = Nothing
Exit Sub
hadi:
MsgBox Err.Number
'MsgBox Err.Description
If Err.Number = 7865 Then
Kill stname
Resume
End If
MsgBox Err.Description
End Sub

لطفا:افسرده: