محمد التميمي قام بنشر أغسطس 5, 2020 مشاركة قام بنشر أغسطس 5, 2020 السلام عليكم اخواني الكرام تعودنا لامر اغلاق الاكسس هو DoCmd.Quit هل يوجد كود يقوم بعملية Restart لبرنامج الاكسس رابط هذا التعليق شارك More sharing options...
Barna قام بنشر أغسطس 5, 2020 مشاركة قام بنشر أغسطس 5, 2020 بعم يمكن ذلك استخدم هذا الكود Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub ثم استدعيه بهذا الكود Private Sub btRestart_Click() Utilities.Restart End Sub 2 1 رابط هذا التعليق شارك More sharing options...
محمد التميمي قام بنشر أغسطس 5, 2020 الكاتب مشاركة قام بنشر أغسطس 5, 2020 الان, Barna said: بعم يمكن ذلك استخدم هذا الكود Private Const TIMEOUT = 99 Public Sub Restart() Dim scriptpath As String scriptpath = Application.CurrentProject.FullName & ".dbrestart.bat" If Dir(scriptpath, vbNormal) <> "" Then If DateAdd("s", TIMEOUT * 1, FileDateTime(scriptpath)) < Date Then Kill scriptpath Else Application.Quit acQuitSaveAll Exit Sub End If End If Dim s As String s = s & "SETLOCAL ENABLEDELAYEDEXPANSION" & vbCrLf s = s & "SET /a counter=0" & vbCrLf s = s & ":CHECKLOCKFILE" & vbCrLf s = s & "ping 0.0.0.255 -n 1 -w 100 > nul" & vbCrLf s = s & "SET /a counter+=1" & vbCrLf s = s & "IF ""!counter!""==""" & TIMEOUT & """ GOTO CLEANUP" & vbCrLf s = s & "IF EXIST ""%~f1.%3"" GOTO CHECKLOCKFILE" & vbCrLf s = s & "start "" "" ""%~f1.%2""" & vbCrLf s = s & ":CLEANUP" & vbCrLf s = s & "del %0" Dim intFile As Integer intFile = FreeFile() Open scriptpath For Output As #intFile Print #intFile, s Close #intFile Dim dbname As String, ext As String, lockext As String Dim idx As Integer For idx = Len(CurrentProject.FullName) To 1 Step -1 If Mid(CurrentProject.FullName, idx, 1) = "." Then Exit For Next idx dbname = Left(CurrentProject.FullName, idx - 1) ext = Mid(CurrentProject.FullName, idx + 1) If Left(ext, 2) = "ac" Then lockext = "laccdb" Else lockext = "ldb" End If s = """" & scriptpath & """ """ & dbname & """ " & ext & " " & lockext Shell s, vbHide Application.Quit acQuitSaveAll End Sub ثم استدعيه بهذا الكود Private Sub btRestart_Click() Utilities.Restart End Sub شكراً اخي على المرور هل اضعه في وحدة نمطية 1 رابط هذا التعليق شارك More sharing options...
Barna قام بنشر أغسطس 5, 2020 مشاركة قام بنشر أغسطس 5, 2020 نعم صحيح والاستدعاء عن طريق زر ممكن 1 رابط هذا التعليق شارك More sharing options...
محمد التميمي قام بنشر أغسطس 5, 2020 الكاتب مشاركة قام بنشر أغسطس 5, 2020 استاذ محمد مع الاسف لم يعمل ويضهر الرسالة بالصورة 55.accdb 1 رابط هذا التعليق شارك More sharing options...
Barna قام بنشر أغسطس 5, 2020 مشاركة قام بنشر أغسطس 5, 2020 جرب الملف --------->> Ba_55.accdb 4 1 رابط هذا التعليق شارك More sharing options...
محمد التميمي قام بنشر أغسطس 5, 2020 الكاتب مشاركة قام بنشر أغسطس 5, 2020 3 دقائق مضت, Barna said: جرب الملف --------->> Ba_55.accdb 376 kB · 0 تنزيلات بارك الله بك استاذي نعم يعمل ولاحظت التغيير شكراً جزيلاً 2 رابط هذا التعليق شارك More sharing options...
Barna قام بنشر أغسطس 5, 2020 مشاركة قام بنشر أغسطس 5, 2020 حياك الله .... بالتوفيق 3 رابط هذا التعليق شارك 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.