قفل ملف اكسيل بعد عدد مرات استعمال ( مساعدة )

[محمد عبد الناصر]

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

 

ده عباره عن ملف يقفل نفسو بعد عدد مرات استعمال معين انا عملو بعد مرتين استعمال بيطلب باسوورد عشان تقدر تستخدم البرنامج تانى  بيقفل بعد عدد 2 استعمال الباسورد 123456

 

بس فى صغرى فى الكود مش عارف احلها بمعنى ان انا دلوقتى فتحت الملف وطلب منى الباسورد وانا مش عارفه اقدر انى افتحو عن طريق انى افتح اى ملف اكسيل جديد واكتب فيه اى حاجه واروح للمف الى طالب باسورد واكنسل هبوص الاقى الملف بتاعى مقفلش هيه دى المشلكه ياريت حد يساعدنى فيها والاقى ليها حل

وشكرا يا احلى منتدى

 

شكر خااااااااص للأستاذ / ياسر خليل أبو البراء

ساعدنى ف مواضيع كتيره جداااااااااا

1.rar

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

هذا الكود الرائع للاخ الجليل ياسر خليل

ارجو ان يفى بالغرض

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If [IK41421] >= 3 Then GoTo 1
    [IK41421] = [IK41421] + 1
1:
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    On Error Resume Next
    Sheets("Sheet1").Select
    
    If [IK41421] >= 3 Then
        'MsgBox "لقد استخدمت البرنامج 3 مرات ولن يفتح إلا بكلمة مرور"
        Dim pwd As String:  pwd = "KHMB12345"
        Cells(Rows.Count, Columns.Count).Activate
        
            If Application.InputBox("برجاء إدخال كلمة المرور لفتح الملف مرة اخري حيث فتح الملف ثلاثون مره ولا يمكن فتحه مرة اخرى الا بالرقم السري", "تصريح دخول للملف ", "???") <> pwd Then
                Sheets("Sheet1").Select
                Workbook.Update
                MsgBox " كلمة المرور غير صحيحة ! من فضلك راجع مسئول النظام حيث تم فتح الملف 3 مرات ، ولا يمكن فتحه مرة أخرى إلا بالرقم السري", 0, "عفواً الدخول محظور"
                ThisWorkbook.Save
                ThisWorkbook.Application.Quit
            Else
                Range("IK41421").Value = 0
                Range("A1").Select
            End If
    End If
End Sub

لينك الموضوع

http://www.officena.net/ib/index.php?showtopic=58098

[محمد عبد الناصر]

شكرا لتعب حضرتك معايه بس تقريبا حضرتك مقرتش الكلام الى انا كاتبو لحد الاخر الملف بتاعى شغال عادى مفهوش مشكله غير لو الملف مفتوح لوحدو لو انا فتحت مثلا ملف جديد واكتبت فيه اى حاجه وجيت افتح البرنامج بتاعى وطلب الباسورد لو انا كنسلت البرنامج مش بيقفل

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

شااااااااايف السطر ده

ThisWorkbook.Application.Quit

غيره للسطر ده وجرب وقولي

ThisWorkbook.Close

[محمد عبد الناصر]

والله يا استاذ اسلام خليل شوف كده فوق انا ذاكرك بكل خير هههه عارف ان انت هنا الى بتجيب من الاخر بجد مش عارف اقولك ايه شغل 10/10 ربنا يجعلو فى ميزان حسناتك

أخر حاجه وعارف انى برخم عليك واسف جدااا دلوقتى بس البرنامج  لما يطلب الباسورد لما بكتبو بيكون ظاهر عادى وانا بكتبو انا عايزو يبان على هيئة نجوم او نقط او اى حاجه عشان محدش يعرف انا بكتب ايه  واسف جدااا لتعبك معايه

تم تعديل يوليو 28, 2015 بواسطه محمود فؤااد

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

أخي الكريم محمد

ارفق ملفك حيث أن المرفق في المشاركة الأولى غير موجود بسبب التحديثات

المطلوب صعب إلى حد ما

[محمد عبد الناصر]

اتفضل

1.rar

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

جرب الملف التالي عله يفي بالغرض

InputBox Password Mask.rar

[محمد عبد الناصر]

لا انا يدوب بفتح الملف بيقولى الباسورد غلط حتى مش بيدينى فرصه اكتب الباسورد

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

هشرح لك الخطوات وإنت نفذها على ملفك بنفسك

روح لمحرر الأكواد ومن قايمة Insert قم بإدراج Class Module وسميه PwdInputBox

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

'---------------------------------------------------------------------------------------
' ClassModule   : PwdInputBox
' DateTime      : 30/07/02 10:30
' Last modified : 31/07/02 08:49
' Author        : Juan Pablo Gonzalez
'                 Special thanks to Ivan F Moala for pointing the right way
' Purpose       : Shows a standard InputBox but with the cabalitie to have a PasswordChar
'                 for the text entered.
' Parameters    : Prompt As String, required.  Text to show on the InputBox
'                 PasswordChar As String, optional. Character to show as PasswordChar.
'                 If vbNullString is entered, the text will show up normally.
'                 Title As String, optional.  Title of the InputBox
'                 Default As String, optional.  Default text to show (Will appear with the
'                 PasswordChar selected.  String character to hide the text entered
'                 XPos As Long, optional.  Horizontal distance between the left border of
'                 the dialog, and the left border of the screen
'                 YPos As Long, optional.  Vertical distance between the upper border of
'                 the dialog, and the upper border of the sreen
' Outputs       : Variant.  Is pressed Ok, the text entered.  If pressed Cancel, False
'---------------------------------------------------------------------------------------

Function PassInputBox(Prompt As String, Optional PasswordChar As String, Optional Title As String, Optional Default As String, Optional XPos As Long, Optional YPos As Long)
    Dim UF                                              'Store the VBComponent
    Dim VUF As Object                                   'Store the userform object
    Dim Lb  As Object                                   'Label for the Prompt
    Dim Tb  As Object                                   'TextBox which holds the password
    Dim BOk  As Object
    Dim BCancel  As Object
    Dim VBAVisible As Boolean                           'Store VBE.Mainwindow visible state to restore it
    Dim I As Integer
    
    'Default Title is the same as InputBox
    If Len(Title) = 0 Then Title = Application.Name
    
    'Store the visible property of the VBE mainwindow and hide it to prevent screen flashing
    VBAVisible = Application.VBE.MainWindow.Visible
    Application.VBE.MainWindow.Visible = False
    
    'Add temporary Userform
    Set UF = ThisWorkbook.VBProject.VBComponents.Add(3)
    
    'Add the textbox.  If no PasswordChar was supplied, the text will appear normally
    Set Tb = UF.Designer.Controls.Add("Forms.Textbox.1", "TextBox1")
    With Tb
        .PasswordChar = PasswordChar
        .Left = 4.5
        .Top = 69.75
        .Width = 254.25
        .Height = 15.75
        .Value = Default
    End With
    
    'Add the prompt
    Set Lb = UF.Designer.Controls.Add("Forms.Label.1")
    With Lb
        .Caption = Prompt
        .WordWrap = True
        .Left = 6.75
        .Top = 6.75
        .Width = 198
        .Height = 54
    End With
    
    'Button OK, it is the default button
    Set BOk = UF.Designer.Controls.Add("Forms.CommandButton.1", "BOk")
    With BOk
        .Caption = "OK"
        .Left = 209.25
        .Top = 4.5
        .Width = 49.5
        .Height = 18
        .Default = True
    End With
    
    'Button Cancel
    Set BCancel = UF.Designer.Controls.Add("Forms.CommandButton.1", "BCancel")
    With BCancel
        .Caption = "Cancel"
        .Cancel = True
        .Left = 209.25
        .Top = 27
        .Width = 49.5
        .Height = 18
    End With
    
    'Add code to the Userform module
    With UF.CodeModule
        I = .CountOfLines
        'MyText is a variant which will hold the answer the user pressed
        .InsertLines I + 0, "Public MyText as Variant"
        
        'Pressed Cancel, so assign False to MyText
        .InsertLines I + 1, "Private Sub BCancel_Click()"
        .InsertLines I + 2, "   MyText = False: Me.Hide"
        .InsertLines I + 3, "End Sub"
        
        'Pressed Ok, so assign the value of TextBox1 to MyText
        .InsertLines I + 4, "Private Sub BOk_Click()"
        .InsertLines I + 5, "   MyText = TextBox1.Value: Me.Hide"
        .InsertLines I + 6, "End Sub"
    
        'Closing the form using "X", so assign False to MyText
        .InsertLines I + 7, "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)"
        .InsertLines I + 8, "   If CloseMode = 0 Then Cancel = True: MyText = False: Me.Hide"
        .InsertLines I + 9, "End Sub"
    End With

    'Properties for the userform
    With UF
        .Properties("Caption") = Title
        .Properties("Width") = 273
        .Properties("Height") = 108.75
        
        'Center on screen or show in a specific position
        If XPos > 0 Or YPos > 0 Then
            .Properties("StartUpPosition") = 0
            .Properties("Left") = XPos
            .Properties("Top") = YPos
        Else
            .Properties("StartUpPosition") = 1
        End If
    End With
    
    'Include the UF in the Userforms collection
    Set VUF = VBA.UserForms.Add(UF.Name)
    
    'Show the Userform
    VUF.Show
    'Pass the result to this function
    PassInputBox = VUF.MyText

    'Remove the VBcomponet
    ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=UF
    
    'Restore the VBE Mainwindow
    Application.VBE.MainWindow.Visible = VBAVisible
End Function

وبعدين في موديول المصنف Workbook ضع الكود الخاص بك مع بعض التعديل في الأسطر

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If [IK41421] >= 2 Then GoTo 1
    [IK41421] = [IK41421] + 1
1:
    ThisWorkbook.Save
End Sub

Private Sub Workbook_Open()
    Dim ANS As Variant
    Dim App As PwdInputBox
    Set App = New PwdInputBox
    
    On Error Resume Next
    Sheets("Sheet1").Select
    
    If [IK41421] >= 2 Then
        Dim pwd As String:  pwd = "123456"
        Cells(Rows.Count, Columns.Count).Activate
        ANS = App.PassInputBox("Enter you password", "*", "Password")
            If ANS <> pwd Then
                Sheets("Sheet1").Select
                Workbook.Update
                MsgBox " Rong Active ! Rong S.N Please tray Agien Later", 0, "You Can,t Enter Sorry "
                ThisWorkbook.Save
                ThisWorkbook.Close
            Else
                Range("IK41421").Value = 0
                Range("A1").Select
            End If
    End If
End Sub

جرب وشوف

[محمد عبد الناصر]

مش عارف حضرتك والله عملت كل الخطوات صح بس بيجبلى ايرور ممكن حضرتك تعملهالى ف ملف من عندك انا اسف ؟

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

جرب الملف التالي

 

InputBox Password Mask.rar

[محمد عبد الناصر]

حضرتك برضو نفس المشكله الى بتواجهنى مش بلحق اكتب الباسورد

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

أنا جربت الملف ويعمل بشكل جيد على أوفيس 2013

ممكن أحد الأخوة الكرام يجرب ويقولنا على النتيجة

فيه فكرة تانية إنك تستخدم فورم لإدخال كلمة السر أفضل من صندوق الإدخال ومن خلال الفورم تضع مربع نص وتخلي خاصية معينة Input Mask تخلي جمبها علامة نجمة عشان يظهر الباسورد على شكل نجوم

 

 

تم تعديل أغسطس 1, 2015 بواسطه ياسر خليل أبو البراء

[مختار البركاني]

شكرا استاذ ياسر

ايضا انا جربت الملف وشغال