طلب مساعدة. في كود لاغلاق الملف بعد وقت معين

[عبدالرحمن بدوى]

السلام عليكم ورحمة الله وبركاته

تحية طيبة الاساتذة الافاضل في هذا المنتدي الراقي

مرفق صورة لكود وظيفته كالتالي

Timer & reset time

وظيفتهم عمل عدادوبعد الانتهاء حفظ الملف واغلاقه

Add time وظيفته انه يضيف 5 دقائق في الخلية a1

Stop timer

وظيفته ايقاف العداد

الهدف من الملف هو اني عايز الملف يقفل بعد وقت معين من ترك الملف بدون اي تعديل

الفكرة انه بيضيف العداد ولما يوصل صفر يحفظ ويقفل

الملف فعلا شغال معايا كويس جدا

لكن فيه مشكلة انه لازم يبقي الفايل مفتوح ومفعل عشان الكود يشتغل

اظن عشان الجزء ده من الكود

Application. Activesheet.range

انه هنا لازم الشيت يكون فعال

لكن لو فتحت ملف تاني وفعلته واشتعلت عليه

الكود ده بيطلع error

ويقف عمله

المطلوب مساعدة في ان الكود يشتغل ايا كان الملف مفعل او لأ

يعني لو معمول minimize

او ملف تاني هو الي فعال بيحصل error والكود يتوقف عن العمل

ومعذرة اني ارفقت صورة بس لأني بكتب من الموبايل لان الملف في الشغل وماينفعش اخذه

وشكرا مقدما

[Ali Mohamed Ali]

جرب هذا الكود

Dim xTime As String

Private Sub Workbook_Open()

    On Error Resume Next

    xTime = Application.InputBox("Please specify the idle time:", "KuTool For Excel", "00:00:20", , , , , 2)

    If xTime = "" Then Exit Sub

    Reset

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    On Error Resume Next

    If xTime = "" Then Exit Sub

    Reset

End Sub

 

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    On Error Resume Next

    If xTime = "" Then Exit Sub

    Reset

End Sub

 

Sub Reset()

    Static xCloseTime

    If xCloseTime <> 0 Then

        ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork", , False

    End If

    xCloseTime = Now + TimeValue(xTime)

    ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork", , True

End Sub

وهذا كود اخر

Option Explicit

Declare Function ExitWindowsEx& Lib "user32" _
                                (ByVal uFlags&, ByVal wReserved&)

 

Public vartimer As Variant
 
Sub Timer()
    Call yahp
    vartimer = Format(Now + TimeSerial(0, 2, 0), "hh:mm:ss")
    If vartimer = "" Then Exit Sub
    Application.OnTime TimeValue(vartimer), "yahm"
End Sub
Sub yahm()
    ActiveWorkbook.Save
      Application.DisplayAlerts = False
      Application.Quit
    
      Shell "shutdown -s -t 02", vbHide
End Sub
Sub yahp()
    On Error Resume Next
    Application.OnTime earliesttime:=vartimer, _
    procedure:="yahm", schedule:=False
    On Error GoTo 0
End Sub

تم تعديل أبريل 7, 2018 بواسطه ali mohamed ali

[عبدالرحمن بدوى]

19 hours ago, ali mohamed ali said:

جرب هذا الكود

Dim xTime As String

Private Sub Workbook_Open()

    On Error Resume Next

    xTime = Application.InputBox("Please specify the idle time:", "KuTool For Excel", "00:00:20", , , , , 2)

    If xTime = "" Then Exit Sub

    Reset

End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

    On Error Resume Next

    If xTime = "" Then Exit Sub

    Reset

End Sub

 

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    On Error Resume Next

    If xTime = "" Then Exit Sub

    Reset

End Sub

 

Sub Reset()

    Static xCloseTime

    If xCloseTime <> 0 Then

        ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork", , False

    End If

    xCloseTime = Now + TimeValue(xTime)

    ActiveWorkbook.Application.OnTime xCloseTime, "SaveWork", , True

End Sub

وهذا كود اخر

Option Explicit

Declare Function ExitWindowsEx& Lib "user32" _
                                (ByVal uFlags&, ByVal wReserved&)

 

Public vartimer As Variant
 
Sub Timer()
    Call yahp
    vartimer = Format(Now + TimeSerial(0, 2, 0), "hh:mm:ss")
    If vartimer = "" Then Exit Sub
    Application.OnTime TimeValue(vartimer), "yahm"
End Sub
Sub yahm()
    ActiveWorkbook.Save
      Application.DisplayAlerts = False
      Application.Quit
    
      Shell "shutdown -s -t 02", vbHide
End Sub
Sub yahp()
    On Error Resume Next
    Application.OnTime earliesttime:=vartimer, _
    procedure:="yahm", schedule:=False
    On Error GoTo 0
End Sub

أشكرك اخى الفاضل على المساعدة

انا اخترت الكود الثانى لانى شعرت انه اخف واسهل

ولكن مع بعض التعديلات

الشيت كان بيقفل الجهاز اصلا ولغيتها

وكان بيقفل الاكسل كله

عدلته انه يقفل الشيت المطلوب فقط

الكود كما يلي

 

 Option Explicit

Public vartimer As Variant
 
Sub Timer()
    Call Stop_timer
    vartimer = Format(Now + TimeSerial(0, 0, 10), "hh:mm:ss")
    If vartimer = "" Then Exit Sub
    Application.OnTime TimeValue(vartimer), "autimatic_close"
End Sub
Private Sub autimatic_close()
Workbooks("close automatic.xlsm").Activate
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
      'Shell "shutdown -s -t 02", vbHide
End Sub
Sub Stop_timer()
    On Error Resume Next
    Application.OnTime earliesttime:=vartimer, _
    procedure:="autimatic_close", schedule:=False
    On Error GoTo 0
End Sub