اذهب الي المحتوي
أوفيسنا

كود وإضافة لفك حماية أوراق العمل في ملف إكسل Sheet Password Remover


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

img_1374395053_560.gif

أتمنى من الله أن تكونوا جميعا بالف خير

حبيت أطرح موضوع أكيد ليس بالجديد ولكنه مفيد أحيانا أتمنى الإفادة للجميع

 

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

ما عليك إلا أن تفتح الملف الذي به الأوراق محمية وتضغط على الزر الذي سيتم تعيينه في الـ Ribbon وسيتم فك التشفير في لحظات

http://forum.tawwat.com/images-topics/images/fa/0042.gif

 

أولا : الكود المستخدم

Public Sub ExcelPasswordRemover()
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

يمكن استخدامه كماكرو عادي

أو يمكن استخدامه كإضافة للإكسل لتكون ثابته في كل الملفات Addin

طريقة إضافة الـ Addins للإكسل كالتالي

 

بعد فتح أي ملف إكسل ومن علامة الإكسل في أقصى اليسار

نضغط عليها ثم نضغط Excel Options

 

5guejM.png

 

ثم من القائمة نضغط على Addin

ثم نضغط Go

 

IFk0lm.png

 

ونختار الإضافة من المكان الذي تم حفظها فيه

 

z1Wrw4.png

 

 

KAt5bY.png

 

 

yRSkOy.png

 

 

 

ثانيا إظهار الإضافة في الـ Ribbon

 

hOeRst.png

 

 

1TihmV.png

 

وأخير قم بفتح أي ملف به صفحات محمية بباسورد وأضغط على الإضافة  كما موضحه في الصورة التالية

 

LdJRKg.png

 

وسيتم فك الحماية بمشية الله

 

 

0042.gif
 

Sheet Password Remover AddIn.rar

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

أخي الحبيب علي الشيخ

جزاكم الله خير الجزاء وبارك الله فيك .. يعجبني جداً أسلوب طرحك للموضوع (وأسلوب ضربك وجمعك بردو ههه)

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

أخي الغالي علي الشيخ

أعتذر عن حذف المشاركات الغير ضرورية والتي تناولنا فيها حل مشكلة الـ AddIn

 وتمت إضافة المرفق الأخير في المشاركة الأولى حتى لا يتشتت الأعضاء الذين يقومون بالإطلاع على الموضوع

 

بارك الله فيك وجزاك الله خير الجزاء في الدنيا والآخرة

ولا حرمنا الله منك ولا من إبداعاتك المتميزة

 

تقبل تحياتي

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

  • 2 weeks later...

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