عكس دالة تشفير

[rey360]

السلام عليكم أريد عكس دالة لتشفير جدول اليوزر ان أمكن هي دالة بسيطة 

Function sedqtr(mott As String)
Dim se As String
se = ""
For i = 1 To Len(mott)
  se = se & Asc(Mid(mott, i, 1)) + Int(100 / 15)
Next

sedqtr = se
End Function

 

[صالح حمادي]

السلام عليكم

هذه دالة ممتازة للتشفير و فك التشفير وضعها الأستاذ @أ / محمد صالح جزاه الله كل خير

Public Const trialdays As Integer = 30
Public Const encodekey As String = "mas"
Public Const regpath As String = "HKEY_CURRENT_USER\software"
Public Const regfolder As String = "masrfirst"
Public Const mainform As String = "main"

Function en_de(sMessage As String, Optional strKey As String = encodekey)
    Dim kLen, x, y, i, j, temp
    Dim s(256), k(256)
 
    'Init keystream
    kLen = Len(strKey)
    For i = 0 To 255
        s(i) = i
        k(i) = Asc(Mid(strKey, (i Mod kLen) + 1, 1))
    Next
 
    j = 0
    For i = 0 To 255
        j = (j + k(i) + s(i)) Mod 255
        temp = s(i)
        s(i) = s(j)
        s(j) = temp
    Next
 
    'Drop n bytes from keystream
    x = 0
    y = 0
    For i = 1 To 3072
        x = (x + 1) Mod 255
        y = (y + s(x)) Mod 255
        temp = s(x)
        s(x) = s(y)
        s(y) = temp
    Next
 
    'Encode/Decode
    For i = 1 To Len(sMessage)
        x = (x + 1) Mod 255
        y = (y + s(x)) Mod 255
        temp = s(x)
        s(x) = s(y)
        s(y) = temp
 
        en_de = en_de & Chr(s((s(x) + s(y)) Mod 255) Xor Asc(Mid(sMessage, i, 1)))
    Next
End Function

قم بوضعها في وحدة نمطية منفصلة

و يتم استدعائها بهذا الشكل

Me.t = en_de(Me.v)

v و t هما أسماء مربعات نص

و هي تقوم بالتشفير و فك التشفير في نفس الوقت

[rey360]

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

 

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

بعد اذن صاحب المشاركه سؤالي الي استاذي الفاضل صالح حمادي

بعد تجربة الكود تظهر لي هذه الرساله

 

 

3333.accdb

[ابوآمنة]

عن إذن أستاذي ومعلمي صالح 

تفضل 

3333.accdb

طبعاً الشفرة تسجل في الريجستري regedit

تم تعديل مارس 29, 2020 بواسطه ابوآمنة

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

الف شكر استاذي الفاضل ابوآمنة

 

[صالح حمادي]

منذ ساعه, ابوآمنة said:

طبعاً الشفرة تسجل في الريجستري regedit

لا يا أخي الشفرة لا تسجل في الرجستري

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

Public Const encodekey As String = "mas"

 

[ابوآمنة]

1 دقيقه مضت, صالح حمادي said:

لا يا أخي الشفرة لا تسجل في الرجستري

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

Public Const encodekey As String = "mas"

 

Public Const regpath As String = "HKEY_CURRENT_USER\software"

ضيعني هذا السطر 

شكراً لك على التنبيه 

لكن هل هو متغيير أم ثابت Const 

[صالح حمادي]

8 ساعات مضت, rey360 said:

ولكن أرد عكس هذيه دالة رغم بساطتها لم أنجح في ذلك وشكر جزيلا لك

أولا يجب إضافة تعديل بسيط لدالتك لتصبح بهذا الشكل:

Function sedqtr(mott As String)
Dim se As String
se = ""
For i = 1 To Len(mott)
  se = se & Format(Asc(Mid(mott, i, 1)), "000") + Int(100 / 15)
Next
sedqtr = se
End Function

الدالة المعاكسة لها تكون كالتالي:

Function sedqtr(mott As String)
Dim se As String
se = ""
For i = 1 To Len(mott) Step 3
  se = se & Chr(Val(Mid(mott, i, 3)) - Int(100 / 15))
Next
sedqtr = se
End Function

 

[صالح حمادي]

منذ ساعه, ابوآمنة said:

شكراً لك على التنبيه 

لكن هل هو متغيير أم ثابت Const

العفو أخي

هو متغير ثابت

[rey360]

شكرا لك أستاذ صالح حمادي أدخلت format لتصبح كل أرقام تتكون من 3 أرقام عوض 1 أو 2 أو 3 فكرة أكثر من جيدة أنا كنت أفكر في عمل دالة عن طريق دوران تتحقق من الارقام  ومع ذلك لم أكن اعرف اذا كانت ستنجح ومن هنا نستنتج أن تهكر الارقام السريال للبرامج و الالعاب ليس بأمر الهين أو السهل

[rey360]

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

Function sedqtr(mott As String)
Dim se As String
se = ""
For i = 1 To Len(mott)
  se = se & Format(Asc(Mid(mott, i, 1))+ Int(100 / 15), "000") 
Next
sedqtr = se
End Function

 

تم تعديل مارس 29, 2020 بواسطه rey360