ahmed_rashed قام بنشر أكتوبر 4, 2018 مشاركة قام بنشر أكتوبر 4, 2018 اريد ضغط واصلاح ونسخه احتياطيه اتوماتيك للبرامج بشكل اتوماتيك مثلا مره واحده أسبوعيا يوم الاثنين 3 عصرا هل هذا ممكن رابط هذا التعليق شارك More sharing options...
Shivan Rekany قام بنشر أكتوبر 4, 2018 مشاركة قام بنشر أكتوبر 4, 2018 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 1 رابط هذا التعليق شارك More sharing options...
ahmed_rashed قام بنشر أكتوبر 4, 2018 الكاتب مشاركة قام بنشر أكتوبر 4, 2018 تسلم يا غالي الكود يعمل تمام رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.