طلب اصلاح ملف ياسر خليل أبو البراء فيه كود أخونا مختار حسين

[عبدالواحد احمد]

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

برجاء المساعده فى تعديل هذا الملف  انه للأخ الغالي و الأستاذ الفاضل " ياسر خليل أبو البراء " بارك الله فيه

لقد اضفت فيه كود  أخونا  "مختار حسين"كود إغلاق آلى لملف اكسل إذا ترك بدون استخدام

واجهتني مشكلة لما اضافات الكود في الملف تظهر رسالة  غلق الملف ولا يتم غلقه 

 

Disable Application Close Button.zip

تم تعديل أبريل 27, 2016 بواسطه عبدالواحد احمد

[بن علية حاجي]

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

أخي الكريم، أعتقد جزما أن المشكل هو في الكود التالي:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not CloseMode Then
        Cancel = True
        MsgBox "Please Use The button To Close This File"
            
       ThisWorkbook.Save
     
    End If
 On Error Resume Next
    Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0

End Sub

قم بحذفه (أو إلغائه) وبإذن الله سيعمل كود الغلق الآلي جيدا...

أخوك بن علية

 

 

[ياسر خليل أبو البراء]

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

أخي الحبيب بن علية بارك الله فيك وجزاك الله خيراً

بالفعل ظنك في محله والمشكلة كما ذكرت في كود حدث ما قبل الإغلاق

ولكن بتجربة الكود الذي تفضلت به يتضح التالي :

لو فتحت المصنف بعد إجراء التعديلات وانتظرت لمدة دقيقة بدون عمل على الملف يتم إغلاق المصنف (أي ينفذ كود الأخ محتار حسين) لا مشكلة في هذه الحالة

أما إذا فتحت المصنف وقمت بمحاولة الإغلاق للتطبيق ستظهر رسالة تفيد باستخدام زر الأمر وأن زر الإغلاق معطل .. اترك الملف لمدة دقيقة أخرى بدون عمل عليه ، لن يتم تفعيل كود الأستاذ مختار

 

وإليك التعديل المطلوب في الملف

يوضع الكود التالي في موديول

Public CloseMode As Boolean
Public RunWhen As Double
Public Const NUM_MINUTES = 1

Public Sub SaveAndClose()
    CloseMode = True
    ThisWorkbook.Save
    Application.Quit
End Sub

ويوضع الكود التالي في حدث المصنف

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If Not CloseMode Then
        Cancel = True
        MsgBox "Please Use The button To Close This File"
    Else
        On Error Resume Next
            Application.OnTime RunWhen, "SaveAndClose", , False
        On Error GoTo 0
    End If
End Sub

Private Sub Workbook_Open()
    On Error Resume Next
        Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
        Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
        Application.OnTime RunWhen, "SaveAndClose", , False
    On Error GoTo 0
    
    RunWhen = Now + TimeSerial(0, NUM_MINUTES, 0)
    Application.OnTime RunWhen, "SaveAndClose", , True
End Sub

تقبل وافر تقديري واحترامي

[عبدالواحد احمد]

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

أخي الحبيب "بن علية حاجي"  واخي الكريم ياسر خليل أبو البراء "بارك الله فيكم وجزاكم الله خيراً

[محمد عبدالسلام]

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

أخي ياسر خليل أبو البراء

جزاك الله خيرا على هذا المجهود

[ياسر خليل أبو البراء]

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

وجزيت خيراً بمثل ما دعوت لي أخي العزيز محمد عبد السلام