اريد ضغط واصلاح ونسخه احتياطيه اتوماتيك

[ahmed_rashed]

اريد ضغط واصلاح ونسخه احتياطيه اتوماتيك للبرامج بشكل اتوماتيك مثلا مره واحده أسبوعيا يوم الاثنين 3 عصرا هل هذا ممكن 

[Shivan Rekany]

2 ساعات مضت, ahmed_rashed said:

اريد ضغط واصلاح ونسخه احتياطيه اتوماتيك للبرامج بشكل اتوماتيك مثلا مره واحده أسبوعيا يوم الاثنين 3 عصرا

اتفضل 
تم استخدام الكود في هذا الرابط لعمل نسخة احتياطي و ضغط و اصلاح

وهذا هو الكود في وحدة النمطية
 

Option Compare Database

Public Function BackUpMyDb()
Dim MyPath As String, math1 As String, math2 As String
    math1 = CurrentProject.Path
    math2 = math1 & "\MyProg"
    MyPath = math2 & "\BackUpSaved"
On Error GoTo MyErr
    Dim OldFile, DBwithEXT, DBwithoutEXT, NewFile, CopyMyDB, TypeApp
        OldFile = CurrentDb.Name
        DBwithEXT = Dir(OldFile)
    If Right(DBwithEXT, 5) = "accdb" Then
            DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 6)
            TypeApp = ".Accdb"
        ElseIf Right(DBwithEXT, 3) = "Mdb" Then
            DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4)
            TypeApp = ".Mdb"
    End If
    If Dir(math2, vbDirectory) = "" Then MkDir math2
    If Dir(MyPath, vbDirectory) = "" Then MkDir MyPath
        NewFile = MyPath & "\" & DBwithoutEXT & "-" & Format(Now, "yyyy-mm-dd-Hh-Nn-Ss") & TypeApp
        CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """"
        Shell CopyMyDB, 0
MyErr:
    If Err.Number <> 0 Then
        MsgBox Err.Number & " - " & Err.Description
    End If

End Function
Public Function compactDb(ByVal mydb As String, ByVal mypass As String, Optional openIt As Boolean = False)
    Dim F As Integer
    Dim filenoext As String, extension As String, Access As String
        Access = """" & SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE"""
        filenoext = Left(mydb, InStrRev(mydb, "."))
        extension = Right(mydb, Len(mydb) - InStrRev(mydb, "."))
        F = FreeFile
    Open CurrentProject.Path & "\compact.bat" For Output As F
    'wait until the Db closes (ldb file is gone), then compact it
        Print #F, "CHCP 1256"
        Print #F, ":checkldb1"
        Print #F, "if exist """ & filenoext & "l" & extension & """ goto checkldb1"
        Print #F, Access & " """ & mydb & """" & mypass & " /compact"
    If openIt Then
    'wait until the Db closes, then start it
        Print #F, ":checkldb2"
        Print #F, "if exist """ & filenoext & "l" & extension & """ goto checkldb2"
        Print #F, Access & " """ & mydb & """"
    Else
        Print #F, "del ""%~f0"""
    End If
        Close F
End Function

Public Function CopactMyDb()
On Error Resume Next
    Dim MyPath As String
        MyPath = CurrentProject.Path & "\" & CurrentProject.Name
        Call compactDb(MyPath, "", True)
        Shell """" & Left(MyPath, InStrRev(MyPath, "\")) & "\compact.bat""", 0
        DoCmd.Quit acQuitSaveAll
End Function

وفي نموذج عند تايمر تم استخدام هذا الكود
 

Option Compare Database

Private Sub Form_Open(Cancel As Integer)
    Me.TimerInterval = 1000
End Sub

Private Sub Form_Timer()
    Me.MyOclock.Caption = Time
    If Time = #3:00:00 PM# And Weekday(Date) = 2 Then Call BackUpMyDb: Call CopactMyDb
End Sub

وتقدر تغير ساعة او اليوم للتجربة عليه
للعلم ليوم الاحد رقم 1 الاثنين رقم 2 الثلاثاء رقم 3 الاربعاء رقم 4 الخميس رقم 5 الجمعة رقم 6 السبت رقم 7
لكن يجب ان يكون النموذج مفتوحة في ذلك الوقت
ولكن حسب رأيي الرابط الاعلاه راح تستفيد منه 
اليك القاعدة

compactInClose (1).accdb

[ahmed_rashed]

تسلم يا غالي الكود يعمل تمام