البحث في الموقع

السلام عليكم نظرا لبعض طلبات الاعضاء الكرام . خاصة ممن يقومون بعمل برامج من أجل كسب العيش أعانهم الله فيما يخص حماية الاكواد التي بملفاتهم لانه عادة ما تحصل سرقة لبرامجهم و هذا بسبب ان أكسل لا يوفر الخماية الكاملة اضافة الى أن هناك برامج تقوم بكشف كلمات سر الملف ببساطة. لذلك اردت أن أقدم فكرة و هي تحويل الكود البرمجي الى ملف DLL مما يوفر حماية قوية للملف عن طريق برنامج vbacompiler for excel و لكن للاسف غير مجاني و هو برنامج يقوم بتحويل الاكواد بالملف الى ملف DLL و تغيير الاكواد بالملف لتستدعى ملف DLL الذي تم انشاؤه و يعمل الملف بكفاءءة عالية لقد قمت بالتجريب و فعلا نتيجة رائعة. يمكنك تحميل البرنامج كنسخة تجريبية . و بالنسبة للذين يعملون البرامج و يبيعونها و يكسبون العيش مننها يمكنهم شراء النسخة الكاملة كيف تحمي ملفك ؟ يمكنك وضع كود خاص بكلمة السر و السريال نمبر للهارد ديسك و ييمكنك وضع الكود التالي عند فتح الملف WORK BOOK OPEN يعني اذاكان رقم السريال نمبر هو مثلا : FFFFF-FFFFF-FFFFF ادخل الرقم السري 222222 و اذا كان خطأا اغلق الملف Private Sub Workbook_Open() Dim RAD As String If CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber = "FFFFF-FFFFF-FFFFF" Then RAD = InputBox("Enter password:") If LCaseRAD <> "222222" Then ActiveWorkbook.Close False End If End Sub و بعد الانتهاء من عمل ملف افتح برنامج vbacompiler for excel و جول ملفك الى ملف جديد معه ملف DLL يمكنك التجريب على أي ملف لقد قمت بتجريب البرنامج على ملف أحد الاعضاء و النتيجة بالمرفقات الملف عبارة عن كود بسيط يبحث عن تكرار في عمودين و نقل المكرر الى عمود ثالث هدا الكود مثلا قبل استعمال برنامج vbacompiler for excel Sub brg() ScreenUpdating = False Dim lr As Integer Dim lr1 As Integer Dim c As Range lr1 = ActiveSheet.Range("g" & Rows.Count).End(xlUp).Row For Each c In ActiveSheet.Range("c2:c1000") lr = ActiveSheet.Range("i" & Rows.Count).End(xlUp).Row If WorksheetFunction.CountIf(ActiveSheet.Range("g2:g" & lr1), c.Value) >= 1 Then Cells(lr + 1, 9) = c.Value On Error Resume Next End If Next ScreenUpdating = True End Sub و هذا بعد استعمال البرنامج #If Win64 Then Private Declare PtrSafe Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq" () #Else Private Declare Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq@0" () #End If Sub brg() p0iflwmc269 End Sub Option Private Module #If Win64 Then Private Declare PtrSafe Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook" (ByVal twbk As Object) As Long Private Declare PtrSafe Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal obj As Object) As Long Private Declare PtrSafe Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal mp As LongPtr) As Long Private Declare PtrSafe Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" () As Variant Private Declare PtrSafe Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" (ByVal dst As Any, ByVal src As LongPtr, ByVal sz As Long) Private Declare PtrSafe Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" (ByRef p() As Any) As LongPtr Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As LongPtr Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As LongLong Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr #Else Private Declare Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook@4" (ByVal twbk As Object) As Long Private Declare Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" Alias "u6hpyov9dx5@8" (ByVal i As Long,ByVal obj As Object) As Long Private Declare Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" Alias "c1smc91ey1mls@8" (ByVal i As Long,ByVal mp As Long) As Long Private Declare Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" Alias "s1a3nzo1yqora3l@0" () As Variant Private Declare Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" Alias "d0np2x0oglsn@12" (ByVal dst As Any,ByVal src As Long,ByVal sz As Long) Private Declare Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" Alias "p8t9c8qi9tgx@4" (ByRef p() As Any) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #End If Private Function k7wgf46mba0cj8() As String On Error Resume Next k7wgf46mba0cj8 = ThisWorkbook.Path + "\EXEMPLE_xlsm_64.dll" End Function Public Sub p8oi75y3jrid8() #If Win64 Then Dim hModule As LongPtr Dim dllPath As String Dim msg As String On Error Resume Next dllPath = k7wgf46mba0cj8() hModule = LoadLibrary(dllPath) If hModule = 0 Then MsgBox "Cannot load '" & dllPath & "'" ThisWorkbook.Close False Else c1smc91ey1mls 1&, AddressOf u4fw2npwzdn25f4 If SetThisWbk(ThisWorkbook) Then u6hpyov9dx5 3&, Sheet1 u6hpyov9dx5 4&, Sheet2 u6hpyov9dx5 2&, ThisWorkbook ThisWorkbook.Saved = True Else GoTo qpnt End If End If #Else MsgBox "This workbook can work with 64 bit Excel only" ThisWorkbook.Close False #End If Exit Sub qpnt: ThisWorkbook.Close False End Sub Public Sub x1u5slqd9g() On Error GoTo errh SetThisWbk (ThisWorkbook) Exit Sub errh: p8oi75y3jrid8 End Sub Public Function q7uobay8mw() As Boolean On Error Resume Next q7uobay8mw = GetModuleHandle("EXEMPLE_xlsm_64.dll") <> 0& End Function #If Win64 Then Public Function FreeCompiledDll() As LongLong Dim i As Long Do FreeCompiledDll = FreeLibrary(GetModuleHandle("EXEMPLE_xlsm_64.dll")) i = i + 1 Loop While FreeCompiledDll <> 0 And i < 100 End Function #End If Private Sub auto_open() x1u5slqd9g End Sub Private Sub auto_close() #If Win64 Then On Error Resume Next Dim p As Variant ThisWorkbook.Saved = True SetThisWbk Nothing p = s1a3nzo1yqora3l FreeCompiledDll If p <> "" Then Kill p & "cbinrtl.dll" RmDir p End If #End If End Sub Function u4fw2npwzdn25f4(ByVal v7liriqd8 As Variant, ByVal m8g6onrhcrw As Variant, ByVal m7jy4oel As Variant, ByRef j8yhrsbf2() As Variant) As Variant On Error Resume Next Dim sz As Long sz = UBound(j8yhrsbf2) - LBound(j8yhrsbf2) + 1 Select Case sz Case 0 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel) Case 1 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0)) Case 2 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1)) Case 3 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2)) Case 4 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3)) Case 5 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4)) Case 6 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5)) Case 7 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6)) Case 8 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7)) Case 9 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8)) Case 10 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8), j8yhrsbf2(9)) End Select End Function و الملف يعمل بكفاءة جيدة يمكنكم التجربة من المرفقات ملف خاص بعد التشفير ب اوفيس 64 و ملف خاص بعد التشفير ب اوفيس 32 و السلام عليكم و تقبل الله منا و منكم الملف بدون تشفير.rar الملف مشفر مع ملف DLL لنسخة اوفيس 32.rar الملف مشفر مع ملف DLL لنسخة اوفيس 64.rar