دخول بعد ساعة بعد فشل دخول لثلاثة مرات محاولة

[ibrahim.]

نرجوا منكم المساعدة في هذا الكود

‫دخول بعد ساعة.xlsm

[محمد هشام.]

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

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

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

Private Sub CommandButton1_Click()
    Dim WS As Worksheet
    Dim Utilisateu As String, Passe As String
    Dim key As Date
    Static Compter As Integer
    
    Set WS = ThisWorkbook.Sheets("Sheet1")
    key = WS.[A1]
    
    '**** تم تحديد قفل الملف 30 ثانية للتجربة****
    Clé = Now + TimeValue("00:00:30")
    '********************************************
    
    'Clé = Now + TimeValue("00:30:00") ' تحديد وقت القفل بعد 30 دقيقة
    WS.Visible = xlSheetVeryHidden
    Utilisateu = TextBox1.Value   'اسم المستخدم
    Passe = TextBox2.Value    ' الرقم السري
    
    ' تغيير لون خلفية مربع كلمة المرور عند الإدخال الخاطئ
    TextBox2.BackColor = RGB(255, 255, 255)  ' اللون الافتراضي
    
    If key > Now Then
        MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _
            Format(key - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف"
        ThisWorkbook.Save
        ThisWorkbook.Close False
        Exit Sub
    End If
    
    If Utilisateu = "admin" And Passe = "1234" Then
        Compter = 0
        MsgBox Utilisateu & " مرحبًــا بك", vbInformation, "ترحيب"
        Application.Visible = True
        Unload Me
    Else
        Compter = Compter + 1
        TextBox2.BackColor = RGB(255, 0, 0)  ' تغيير اللون إلى الأحمر عند الإدخال الخاطئ
        
        If Compter >= 3 Then   ' تحديد عدد المحاولات المسموح بها
            key = Clé: WS.[A1] = key
            MsgBox "تم قفل الملف لمدة 30 دقيقة", vbCritical, "تعذر الدخول للملف"
            Compter = 0
            ThisWorkbook.Save
            ThisWorkbook.Close False
            Exit Sub
        Else
            MsgBox "بيانات الدخول غير صحيحة. محاولة " & _
                Compter & " من 3", vbExclamation, "إنتباه"
        End If
    End If
End Sub

وفي حدث ThisWorkbook

Private Sub Workbook_Open()
    Dim kay As Date
    On Error Resume Next
    kay = Sheets("Sheet1").Range("A1").Value
    On Error GoTo 0
    
    If kay > Now Then
        MsgBox "الملف مغلق يرجى المحاولة مرة أخرى بعد " & _
        Format(kay - Now, "hh:mm:ss") & ".", vbExclamation, "تعذر الدخول للملف"
        ThisWorkbook.Save
        ThisWorkbook.Close False
    Else
        Application.Visible = False
        UserForm1.Show
    End If
End Sub

بالتوفيق..

 

دخول بعد ساعة.xlsm

تم تعديل أغسطس 26 بواسطه محمد هشام.

[ibrahim.]

محمد هشام.

• شكرا جزيلا لك وبارك الله فيك