كود Restart بزر امر

[محمد التميمي]

السلام عليكم

اخواني الكرام تعودنا لامر اغلاق الاكسس هو DoCmd.Quit 

هل يوجد كود يقوم بعملية  Restart لبرنامج الاكسس 

[Barna]

بعم يمكن ذلك

استخدم هذا الكود 

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

 

[محمد التميمي]

الان, 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

 

شكراً اخي على المرور

هل اضعه في وحدة نمطية

[Barna]

نعم صحيح والاستدعاء عن طريق زر ممكن 

[محمد التميمي]

استاذ محمد مع الاسف لم يعمل ويضهر الرسالة بالصورة

55.accdb

[Barna]

جرب الملف --------->>

 

Ba_55.accdb

[محمد التميمي]

3 دقائق مضت, Barna said:

جرب الملف --------->>

 

Ba_55.accdb 376 kB · 0 تنزيلات

بارك الله بك استاذي نعم يعمل ولاحظت التغيير شكراً جزيلاً

[Barna]

حياك الله .... بالتوفيق