تشفير وفك تشفير البيانات Encrypt And Decrypt Function

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

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

 

هل لديك بيانات حساسة ومهمة في ورقة العمل تريد ألا يطلع عليها أحد؟ 

طرق الحماية للإكسيل كما يعرف الجميع ضعيفة ، لذا فإن تشفير البيانات هو الحل الأمثل للوصول إلى حماية أفضل للبيانات.

 

 

إخواني الكرام أقدم لكم طريقة لتشفير البيانات في ملفك ، وبنفس الكود ستتمكن من فك تشفير البيانات.

 

خطوات العمل :

>> قم بالدخول لمحرر الأكواد عن طريق Alt + F11 ، ثم من قائمة Insert أدرج موديول جديد Module ، وأخيراً الصق الكود التالي داخل الموديول.

 

>> قم برسم زر أمر على ورقة العمل ، ثم كليك يمين على الزر واختر الأمر Assign Macro ثم اختر الإجراء الفرعي المسمى Encrypt_Decrypt

 

Sub Encrypt_Decrypt()
    Dim xRg             As Range
    Dim xPsd            As String
    Dim xTxt            As String
    Dim xEnc            As Boolean
    Dim xRet            As Variant
    Dim xCell           As Range

    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Select A Range:", "Select Range To Encrypt / Decrypt", xTxt, , , , , 8)
    Set xRg = Application.Intersect(xRg, xRg.Worksheet.UsedRange)
    If xRg Is Nothing Then Exit Sub
    
    xPsd = InputBox("Enter Password:", "Pass Entry")
    If xPsd = "" Then
        MsgBox "Password Cannot Be Empty", , "Kutools For Excel"
        Exit Sub
    End If
    
    xRet = Application.InputBox("Type 1 To Encrypt Cell(s)" & vbNewLine & vbNewLine & "Type 2 To Decrypt Cell(s)", "Encrypt = 1 / Decrypt = 2", , , , , , 1)
    If TypeName(xRet) = "Boolean" Then Exit Sub
    If xRet > 0 Then
        xEnc = (xRet Mod 2 = 1)
        For Each xCell In xRg
            If xCell.Value <> "" Then
                xCell.Value = Encryption(xPsd, xCell.Value, xEnc)
            End If
        Next xCell
    End If
End Sub

Private Function StrToPsd(ByVal Txt As String) As Long
    Dim xVal            As Long
    Dim xCh             As Long
    Dim xSft1           As Long
    Dim xSft2           As Long
    Dim I               As Integer
    Dim xLen            As Integer
    
    xLen = Len(Txt)
    
    For I = 1 To xLen
        xCh = Asc(Mid$(Txt, I, 1))
        xVal = xVal Xor (xCh * 2 ^ xSft1)
        xVal = xVal Xor (xCh * 2 ^ xSft2)
        xSft1 = (xSft1 + 7) Mod 19
        xSft2 = (xSft2 + 13) Mod 23
    Next I
    
    StrToPsd = xVal
End Function

Private Function Encryption(ByVal Psd As String, ByVal InTxt As String, Optional ByVal Enc As Boolean = True) As String
    Dim xOffset         As Long
    Dim xLen            As Integer
    Dim I               As Integer
    Dim xCh             As Integer
    Dim xOutTxt         As String
    
    xOffset = StrToPsd(Psd)
    Rnd -1
    Randomize xOffset
    xLen = Len(InTxt)
    
    For I = 1 To xLen
        xCh = Asc(Mid$(InTxt, I, 1))
        If xCh >= 32 And xCh <= 126 Then
            xCh = xCh - 32
            xOffset = Int((96) * Rnd)
            If Enc Then
                xCh = ((xCh + xOffset) Mod 95)
            Else
                xCh = ((xCh - xOffset) Mod 95)
                If xCh < 0 Then xCh = xCh + 95
            End If
            xCh = xCh + 32
            xOutTxt = xOutTxt & Chr$(xCh)
        End If
    Next I
    
    Encryption = xOutTxt
End Function

 

شرح كيفية استخدام الكود : 

لتشفير البيانات : حدد النطاق أو الخلايا المراد تشفير البيانات بها ، انقر على زر الأمر ليظهر لك صندوق إدخال يمكنك من خلاله تحديد النطاق ، وبما أنك قمت بتحديد النطاق في البداية فلن يكون لديك سوى أن تنقر OK ، لتنتقل إلى صندوق إدخال آخر بعنوان Pass Entry ومن خلاله تدخل كلمة السر للتشفير ، وليكن 111 ، ثم انقر OK

الآن سيظهر آخر صندوق إدخال وهو لإدخال الرقم 1 (للتشفير) ، أو الرقم 2 (لفك التشفير)

بما أننا نريد التشفير سنقوم بكتابة الرقم 1 ثم ننقر OK ، ولاحظ البيانات في النطاق (لقد تم الأمر بحمد الله)

 

لفك التشفير : ستقوم بتكرار نفس الخطوات بالضبط وتدخل نفس كلمة السر ، وفي آخر صندوق إدخال ستقوم بإدخال الرقم 2 لفك التشفير

 

وأخيراً إليكم صورة توضيحية لكيفية التعامل مع الكود

 

 

لتحميل الملف المرفق قم بزيارة الرابط للموضوع

رابط الموضوع من هنا

 

[جلال الجمال_ابو ادهم]

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

جزاك الله خيرا 

الناس شكلها  نايمه 

الواحد حزين من قلة التفاعل فى المنتدى 

تحياتى 

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

بارك الله فيك أخي الكريم جلال الجمال ، ومشكور على مرورك العطر

لا تقلق فكل منا له ما يشغله .. ولكن بالنهاية نكون هنا في نهاية المطاف

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

[عادل ابوزيد]

الاستاذ الكبير الباشمهندس ياسر

هل هذا التشفير اذا تم على نظاق به معادلات وهذه المعادلات تؤثر على بيانات اخرى هل تؤثر عليها .. بمعنى ادق هل التشفير فى الشكل ام يؤثر فى المضمون

تقبل تحياتى

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

بعد التجربة اتضح أنه يؤثر على الخلايا التي بها معادلات ..عموماً بسيطة قم بتعديل السطر التالي في الكود

For Each xCell In xRg.SpecialCells(xlCellTypeConstants)

 

[ياسر العربى]

حبيبي ابو البراء  معلش بقى مكان ما تحط تشفيرك احط تشفيري
 تفضلو تشفير كل انواع الملفات ولا يستطيع احد فتحها من الخارج
http://yasserelaraby86.blogspot.com.eg/2016/04/blog-post_24.html

تقبل تحياتي

[جلال الجمال_ابو أدهم]

ياسر العربى

اخى الفاضل تحياتى

و جزاك الله خيرا
و بعد اذنك تم رفع الرابط فى مشاركه منفصله لاهميته 

 

من هنا تشفير كل انواع الملفات