اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

إلغاء أى حماية لشيت إكسيل بخطوة واحدة


الردود الموصى بها

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

أحبائى فى الله

أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت

Sub PasswordBreaker()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub

 

  • Like 6
رابط هذا التعليق
شارك

اخي الغالي ياسر

مشكور علي الموضوع المهم  خصوصا لمن فقد او نسى

كلمة مرور الخاصة به  لشيت معين

 بالمثل الكود الذي يقوم بفك حماية   اكواد الvba

لمن نسى حماية اكواده داخل اي ملف

ولكن لي نظرة في هذه المواضيع وهي

كثرة استخدام هذه الاكواد في فك حماية ملفات خاصة باشخاص قد تعبت علي برامجها

وسهرت عليها وفي الاخر يجي واحد بكود ويفك الحماية وينسب مثلا الاعمال دي ليه

وهي دي النقطة  اللي تجعلنا لا نكثر من مثل هذه المواضيع

لك فائق شكري واحترامي

 

  • Like 1
رابط هذا التعليق
شارك

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

بارك الله فيك أستاذي الفاضل "ياسر فتحي البنّا" على الكود الرّائع .. فعلاً أحيانا الواحد منّا ينسى كلمة المرور لكثرة الملفات و تغيير كلمات المرور من ملف لملف

جزاك الله خيرًا و زادها بميزان حسناتك .. و زادك من علمه و فضله

فائق إحتراماتي

  • Like 1
رابط هذا التعليق
شارك

اخي الغالي ياسر

مشكور علي الموضوع المهم  خصوصا لمن فقد او نسى

كلمة مرور الخاصة به  لشيت معين

 بالمثل الكود الذي يقوم بفك حماية   اكواد الvba

لمن نسى حماية اكواده داخل اي ملف

ولكن لي نظرة في هذه المواضيع وهي

كثرة استخدام هذه الاكواد في فك حماية ملفات خاصة باشخاص قد تعبت علي برامجها

وسهرت عليها وفي الاخر يجي واحد بكود ويفك الحماية وينسب مثلا الاعمال دي ليه

وهي دي النقطة  اللي تجعلنا لا نكثر من مثل هذه المواضيع

لك فائق شكري واحترامي

 

أخى الحبيب / ياسر العربى

يسعدنى مرورك الكريم

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

ويتسبب فى عطلة له

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

تقبل خالص تحياتى وتقديرى

 

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

بارك الله فيك أستاذي الفاضل "ياسر فتحي البنّا" على الكود الرّائع .. فعلاً أحيانا الواحد منّا ينسى كلمة المرور لكثرة الملفات و تغيير كلمات المرور من ملف لملف

جزاك الله خيرًا و زادها بميزان حسناتك .. و زادك من علمه و فضله

فائق إحتراماتي

يسعدنى ويشرفنى مرورك الكريم دائما على موضوعاتى أخى الحبيب / عبد العزيز السكرى

شكرا لدعائك الطيب وجزيت بمثله

تقبل تحياتى وإحترامى

  • Like 1
رابط هذا التعليق
شارك

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

أحبائى فى الله

أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت

Sub PasswordBreaker()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub

 

بارك الله فيك اخي ياسر بالفعل هذا الكود مميز استخدمته منذ عامين وفقدته وتعبت حتي حصلت عليه ثانيه 

جزاك الله خيرا لتعميمك الفائده

  • Like 1
رابط هذا التعليق
شارك

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

شكرا م/ ياسر فتحي جزاك الله خير علي رفع مثل هذه الاكواد المندثرة في المنتدى

هذا الكود موجود بالمنتدى قديم جدا ولكن تدويرة وإظهاره للفائده للاخرين .

تم تعديل بواسطه KHMB
  • Like 1
رابط هذا التعليق
شارك

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

شكرا م/ ياسر فتحي جزاك الله خير علي رفع مثل هذه الاكواد المندثرة في المنتدى

هذا الكود موجود بالمنتدى قديم جدا ولكن تدويرة وإظهاره للفائده للاخرين .

شكرا جزيلا أخى KHMB

وشكرا لدعائك

رابط هذا التعليق
شارك

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

أحبائى فى الله

أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت

Sub PasswordBreaker()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub

 

جزاكم الله خيرا اخي الفاضل .. فعلا كود متميز

تم تعديل بواسطه احمد الحاوي
رابط هذا التعليق
شارك

السلام عليكم أخي الحبيب م / ياسر

جزاكم الله خيراً ...كود ناجح و رائع حقاً...تشكر عليه

نرجو لك دوام التقدم والازدهار..

والسلام عليكم

الأستاذ القدير / محمد حسن المحمد

شكرا لمرورك العطر دائما على موضوعاتى وتشجيعك الدائم لى

تقبل خالص تحياتى وتقديرى

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

أحبائى فى الله

أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت

Sub PasswordBreaker()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub

 

جزاكم الله خيرا اخي الفاضل .. فعلا كود متميز

شكرا لك أخى الفاضل / أحمد الحاوى

بارك الله فيك

  • Like 1
رابط هذا التعليق
شارك

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

أحبائى فى الله

أقدم لكم اليوم كود يوضع فى حدث الشيت المراد فك حمايته يقوم بإلغاء الحماية عن الشيت

Sub PasswordBreaker()
    'Breaks worksheet password protection.
    Dim i As Integer, j As Integer, k As Integer
    Dim l As Integer, m As Integer, n As Integer
    Dim i1 As Integer, i2 As Integer, i3 As Integer
    Dim i4 As Integer, i5 As Integer, i6 As Integer
    On Error Resume Next
    For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
    For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
    For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
    For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
    ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _
        Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
        Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
    If ActiveSheet.ProtectContents = False Then
        MsgBox "One usable password is " & Chr(i) & Chr(j) & _
            Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
            Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
         Exit Sub
    End If
    Next: Next: Next: Next: Next: Next
    Next: Next: Next: Next: Next: Next
End Sub

 

رابط هذا التعليق
شارك

.. جزاك الله خيرا أخي ياسر و زادها بميزان حسناتك وليس غريبا منك هذا الإبداع

جزاك الله خيرا أخى الحبيب الزباري على مرورك الدائم

 

رابط هذا التعليق
شارك

  • 7 months later...

استاذنا الكبير ياسر العربى

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

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

تم تعديل بواسطه عادل زكى
رابط هذا التعليق
شارك

Public Sub Sheetpasswordremover()

Dim Mess As String, Header As String
Dim Credit As String
Dim RepBack As String, AllClear As String
Dim PWord1 As String
Dim ShTag As Boolean, WinTag As Boolean
Dim w1 As Worksheet, w2 As Worksheet
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, i1 As Integer, i2 As Integer
Dim i3 As Integer, i4 As Integer, i5 As Integer, i6 As Integer
Application.ScreenUpdating = False
Header = "فك تشفير صفحات الإكسل"
Credit = vbNewLine & vbNewLine & "منتديات أوفيسنا التعليمية"
RepBack = vbNewLine & vbNewLine & "www.officena.com"
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
End With
ShTag = False
For Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag And Not WinTag Then
Mess = vbNewLine & "لا يوجد كلمة سر للصفحات الحالية" & vbNewLine & Credit
MsgBox Mess, vbInformation, Header
Exit Sub
End If
Mess = "سوف تستغرق عملية فك الحماية ثواني معدودة" & _
vbNewLine & "OK إضغط " & vbNewLine & "وإنتظر حتى يتم فك الحماية " & vbNewLine & _
Credit
MsgBox Mess, vbInformation, Header
If Not WinTag Then
Mess = "" & _
"" & vbNewLine & _
"جاري حذف الحماية " & _
Credit
MsgBox Mess, vbInformation, Header
Else
On Error Resume Next
Do
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = False Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Mess = "You had a Worksheet Structure or " & vbNewLine & _
Credit
MsgBox Mess, vbInformation, Header
Exit Do
End If
End With
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
If WinTag And Not ShTag Then
Mess = "Only structure / windows protected with " & vbNewLine & _
"the password that was just found." & vbNewLine & _
AllClear & Credit & RepBack
MsgBox Mess, vbInformation, Header
Exit Sub
End If
On Error Resume Next
For Each w1 In Worksheets
w1.Unprotect PWord1
Next w1
On Error GoTo 0
ShTag = False
For Each w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag Then
Mess = AllClear & Credit & RepBack
MsgBox Mess, vbInformation, Header
Exit Sub
End If
For Each w1 In Worksheets
With w1
If .ProtectContents Then
On Error Resume Next
Do
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Not .ProtectContents Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
Mess = "تم حذف كلمة السر " & _
Credit
MsgBox Mess, vbInformation, Header
For Each w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do
End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error GoTo 0
End If
End With
Next w1
Mess = AllClear & Credit & RepBack
MsgBox Mess, vbInformation, Header
End Sub

ربنا يبارك في كل واحد يفيد اخوانه بالعلم الذي افاض الله به عليه

ربنا يحفظ صاحب هذا العمل .. يارب

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information