من از این کد برای compact and repair استفاده میکنم اگر فقط هدف گرفتن یک کپی ساده است خوب بفرمایید(Visual Basic Script file .VBS)
Set Dbe = CreateObject("DAO.DBEngine.36")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")
Const SW_SHOWMAXIMIZED = 3
ARGSNO=WScript.Arguments.COUNT
if ARGSNO > 0 then
DbName=WScript.Arguments.Item(I)
Else
WScript.Quit
End if
Pos = InStrRev(DbName, "\")
Na = Mid(DbName, Pos + 1)
Pa = Left(DbName, Pos)
FreeName = GetFreeName(Pa,Na)
On Error Resume Next
Do
Err.Clear
Dbe.CompactDatabase DbName ,Pa & FreeName
Loop While Err <> 0
On Error Goto 0
FSO.DeleteFile DbName ,True 'Delete the Source File
FSO.MoveFile Pa & FreeName,DbName 'Rename The DesFile 2 SrcFil
FSO.DeleteFile WScript.ScriptFullName 'Delete the Source Script
WSHShell.Run "%windir%\Explorer.exe " & DbName, SW_SHOWMAXIMIZED , False
Function GetFreeName(Directory , DefaultName )
if DefaultName="" then
DefaultName= "NewFile.Tmp"
End If
i = InStrRev(DefaultName, ".")
FileName = left(DefaultName,i-1)
Ext= Mid(DefaultName, i )
i=0
If (FSO.FolderExists(Directory)) Then
Do While fso.FileExists(Directory & FileName & EXT)
FileName = FileName & i
i = i + 1
Loop
Else
GetFreeName = vbNullString
End If
GetFreeName = FileName & EXT
End Function
اما تابعی که من استفاده میکنم
Dim TBLName As String, FN As String, SqlStr As String, Na As String, Pa As String
Dim ANS As Boolean
Dim Db As Database
Dim fso
On Error GoTo Compact_Click_Err_handler
FN = TXTFileName.Value
'FN = Right(FN, Len(FN) - InStrRev(FN, "\"))
TXTFileName.SetFocus
CloseForm.Enabled = False
Compact.Enabled = False
DoCmd.Hourglass True
'******************* Start Importing
'1-Creat File And Copy DAta to That
Label1.ForeColor = vbYellow
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FN) Then Kill FN
Set Db = CreateDatabase(FN, dbLangGeneral)
Db.Close
ANS = Export_All_Tabels(FN, True, False, True)
If ANS Then
Label1.ForeColor = vbGreen
Else
Label1.ForeColor = vbRed
GoTo Compact_Click_Err_handler
End If
'2-Compact & repair DataBase
Label2.ForeColor = vbYellow
DoEvents
Pos = InStrRev(FN, "\")
Na = Mid(FN, Pos + 1)
Pa = Left(FN, Pos)
Na = GetFreeFileName(Pa, Left(Na, InStrRev(Na, ".")), "MDB")
DBEngine.CompactDatabase FN, Na
Kill FN
Label2.ForeColor = vbGreen
'3-Zip The Database File
Label3.ForeColor = vbYellow
DoEvents
Zip1.OutputFile = FN
Zip1.InputFile = Pa & Na
Zip1.Go
Kill Pa & Na
Label3.ForeColor = vbGreen
Restore_Orginals:
CloseForm.Enabled = True
If Len(TXTFileName.Value) > 0 Then Compact.Enabled = True
DoCmd.Hourglass False
Label1.ForeColor = 9868950
Label2.ForeColor = 9868950
Label3.ForeColor = 9868950
Exit Sub
Compact_Click_Err_handler:
If Err.Number = 0 Then
MsgBox "ÚãáíÇ&Ecir c; ÈÇ ÎØÇ ãæÇÌå ÔÏ áØÝÇ ÏæÈÇÑå ÊáÇÔ ˜äíÏ." & _
vbCrLf & "ÏÑ ÕæÑÊ ãÔÇåÏå ãÊæÇáí Çíä íÇã ÈÇ ØÑÇÍ ÊãÇÓ ÈíÑíÏ" _
, vbCritical + vbMsgBoxRight + vbOKOnly, Space(60) & "ÈÑæÒ ÎØÇ åäÇã ÇíÍÇÏ ÔÊíÈÇä"
Else
ErrorControl Err.Number
End If
Resume Restore_Orginals
این تابع را هم که فراخوانی کردم
Function Export_All_Tabels(ByVal MDB_FileNamePath As String, _
Optional ByVal RelationSh As Boolean = True, _
Optional ByVal SystemTables As Boolean = False, _
Optional ByVal OverWriteAll As Boolean = True) As Boolean
On Error GoTo Export_All_Tabels_Err_Handler
'*************** Init ************
Export_All_Tabels = False
'*********************************
Dim Des_Name As String
Dim AllTableDefs As TableDefs
Dim MyDb As Database
Dim LErrAction As VBA.VbMsgBoxResult
Set MyDb = CurrentDb
Set AllTableDefs = MyDb.TableDefs
For i = 0 To AllTableDefs.Count - 1
ANS = vbNullString
If (AllTableDefs(i).Attributes = 0) Or SystemTables Then _
ANS = Export_To_External_Database(MDB_FileNamePath, AllTableDefs(i).Name, _
AllTableDefs(i).Name, acExport, acTable, OverWriteAll)
If Len(ANS) > 0 Then
Debug.Print AllTableDefs(i).Name & vbTab & "Exported Correctly as " & ANS
Else
Debug.Print "Some Error Accured on Exporting" & vbTab & AllTableDefs(i).Name
End If
Next
MyDb.Close
'If RelationSh Then Set MyDb.CreateRelation = CurrentDb.Relations
'For j = 0 To AllTableDefs.Count - 1
If RelationSh Then
Set MyDb = OpenDatabase(MDB_FileNamePath)
Dim rel As Relation
Dim L As Field
For i = 0 To CurrentDb.Relations.Count - 1
Set rel = MyDb.CreateRelation
rel.Name = CurrentDb.Relations(i).Name
rel.Table = CurrentDb.Relations(i).Table
rel.ForeignTable = CurrentDb.Relations(i).ForeignTable
rel.Attributes = CurrentDb.Relations(i).Attributes
For j = 0 To CurrentDb.Relations(i).Fields.Count - 1
Set L = rel.CreateField
L.Name = CurrentDb.Relations(i).Fields(j).Name
L.ForeignName = CurrentDb.Relations(i).Fields(j).ForeignName
rel.Fields.Append L
Next
MyDb.Relations.Append rel
Debug.Print "Crete relation from " & CurrentDb.Relations(i).Table & _
vbTab & "To " & CurrentDb.Relations(i).ForeignTable
Next
MyDb.Close
End If
If LErrAction <> vbIgnore Then Export_All_Tabels = True Else Export_All_Tabels = False
Exit Function
Export_All_Tabels_Err_Handler:
ANS = MsgBox(Err.Number & vbCrLf & Err.Description & vbCrLf & "Do you want to Try Again?" _
, vbCritical + vbAbortRetryIgnore)
Select Case ANS
Case vbRetry
LErrAction = vbRetry
Resume
Case vbIgnore
LErrAction = vbIgnore
Resume Next
Case vbAbort
LErrAction = vbAbort
Export_All_Tabels = vbNullString
Exit Function
Case Else
LErrAction = vbAbort
Export_All_Tabels = vbNullString
Exit Function
End Select
End Function
اینم اون یکیش
Function Export_To_External_Database _
(ByVal MDB_FileNamePath As String, ByVal SourceName As String, _
Optional ByVal DestenationName As String = "_ExportedTable_", _
Optional ByVal ExportType As Access.AcDataTransferType = acExport, _
Optional ByVal ObjectType As Access.AcObjectType = acTable, _
Optional Overwrite As Boolean = False) As String
On Error GoTo Export_To_External_Database_Err_Handler
Dim Des_Name As String
Dim AllTableDefs As TableDefs
Dim MyDb As Database
Dim LErrAction As VBA.VbMsgBoxResult
'*************** Init ************
Des_Name = DestenationName
Export_To_External_Database = vbNullString
Err.Clear
'*********************************
Func_Start:
Set MyDb = OpenDatabase(MDB_FileNamePath, True)
Set AllTableDefs = MyDb.TableDefs
If Not Overwrite Then
For i = 0 To AllTableDefs.Count - 1
If Des_Name = AllTableDefs(i).Name Then
'***** if you prefer retry use these
ANS = MsgBox("The Tabel You Select Is Currently Exist Do You Want To OverWrite It?", _
vbExclamation + vbYesNoCancel, "Remeving Some Object")
If ANS = vbNo Then
Des_Name = InputBox("Enter The Table Name", "Choose Destenation Tabel Name")
GoTo Func_Start
Else: If ANS = vbCancel Then Exit Function
End If
'***********************************
End If
Next
End If
If Des_Name = "_ExportedTable_" Then Des_Name = Des_Name & File_Name
MyDb.Close
DoCmd.TransferDatabase ExportType, "Microsoft Access", _
MDB_FileNamePath, ObjectType, SourceName, Des_Name
' if no Error accrued return the Table Name
If LErrAction <> vbIgnore Then Export_To_External_Database = Des_Name
Exit Function
Export_To_External_Database_Err_Handler:
ANS = MsgBox(Err.Number & vbCrLf & Err.Description & vbCrLf & "Do you want to Try Again?" _
, vbCritical + vbAbortRetryIgnore)
Select Case ANS
Case vbRetry
LErrAction = vbRetry
Resume
Case vbIgnore
LErrAction = vbIgnore
Resume Next
Case vbAbort
LErrAction = vbAbort
Export_To_External_Database = vbNullString
Exit Function
Case Else
LErrAction = vbAbort
Export_To_External_Database = vbNullString
Exit Function
End Select
End Function
--------------------
اااااااااااااا چقد زیاد شد. خوب امیدوارم بدرد بخوره مشکل داشتید بگید شاید بلد بودم جواب دادم.
ضمنا من کپی و پیست کردم اگر غلط غلوط داره بگید :)
نوشته شده توسط evilboy
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول