كود رهيب لقفل الملف مع الفلاش ميمري

[لؤي الخزرجي]

السلام عليكم

اخواني الاعزاء

خلال تصفحي لاحدى المنتديات صادفني كود جميل للحماية عن طريق الفلاش ميمري

ولكن ينقصة الشرح والتنفيذ على ملف اكسل كمثال

 

الكود يحتاج لبعض التعديلات البسيطة

تحياتي

اعتماد السيريال الخاص بالهارد دسك

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

لاخراج رقم الفلاش ميموري في الزر الخاص باخراج هذا الرقم تم وضع هذا الكود
كود
Dim fso As Object
Dim dc As Object
Dim d As Object
Dim xx, xxx As String
On Error GoTo diskerror


Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.Drives
For Each d In dc
If d.DriveType = 3 Then
n = d.ShareName
End If
Select Case d.DriveType
'البحث عن قطعه مؤقتة مثل الفلاش ميموري


Case 1
'تعريف يساوي اسم الفلاش ميموري مضاف اليه النقطتين والخط المائل
xx = d.DriveLetter + ":\"
End Select
Next
' تساوي الرقم الستلسلي
' xx هو اسم الفلاش ميموري
xxx = CreateObject("Scripting.FileSystemObject").GetDriv e(xx).SerialNumber
MsgBox xxx
diskerror:


If Err.Number = 71 Then
MsgBox "لايوجد فلاش ميمري"
Resume Next
End If


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


كود
On Error Resume Next


Dim fso As Object
Dim dc As Object
Dim d As Object
Dim xx, xxx As String


Set fso = CreateObject("Scripting.FileSystemObject")
Set dc = fso.Drives
For Each d In dc
If d.DriveType = 3 Then
n = d.ShareName
End If
Select Case d.DriveType
Case 1
xx = d.DriveLetter + ":\"
End Select
Next
xxx = CreateObject("Scripting.FileSystemObject").GetDriv e(xx).SerialNumber
If xxx = "رقم الفلاش ميموري" Then
MsgBox " hi"
Else
MsgBox "الرقم التسلسلي غير مطابق"
DoCmd.Quit
End If 

[لؤي الخزرجي]

up

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

ممكن أخي الحبيب تضع رابط المصدر للكود للإطلاع على الموضوع ..

[عبدالله المجرب]

هذا الكود تم استعماله مع ملف اكسس على ما اعتقد والله اعلم 

[عبدالله المجرب]

السلام عليكم 

 

اخي الفاضل اليك الملف المرفق

 

في الملف ستجد زر سيقوم بإظهار رقم الفلاشة 

 

هذا الرقم تكتبه في حدث ThisWorkbook

 

في هذا السطر 

'If xxx = "رقم الفلاشه ضعه هنا" Then

ثم تقوم بإزالة الفاصلة الموجودة في بداية هذه الاسطر 

'If xxx = "رقم الفلاشه ضعه هنا" Then
'MsgBox " hi"
'Else
'MsgBox "الرقم التسلسلي غير مطابق"
'Application.Quit
'End If

ثم تحفظ ما قمت به بعد ذلك افتح الملف 

 

اذا كانت الفلاشة مختلفة لن يعمل الملف لعدم تطابق الرقم التسلسلي 

 

وشكراً 

الفلاشة.zip

[خالد الشاعر]

شكرا للاستاذ لؤى

 

الشكر للاستاذ عبد الله

 

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

[صلاح الصغير]

ا / عبد الله

 

رائع جدا و لكن لاتمام الحماية يوجد كود اعتقد هو للاستاذ / ابراهيم ابو ليلة او الاستاذ / ياسر خليل

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

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

اعتقد انه احد الكودين التالين او احدهما الله اعلم

 

Private Sub Workbook_BeforeClose(Cancel As Boolean)
kh_wVisible False
ThisWorkbook.Close Not CBool(ThisWorkbook.Saved)
End Sub

 

Private Sub Workbook_Open()
Application.Visible = False
kh_AhlnWShln
End Sub

[عبدالله المجرب]

 

 

رائع جدا و لكن لاتمام الحماية يوجد كود اعتقد هو للاستاذ / ابراهيم ابو ليلة او الاستاذ / ياسر خليل

 

الكود للأستاذ عبدالله باقشير 

 

ويمكنك نقله بسهولة الى ملفك 

[صلاح الصغير]

ا / عبد الله

 

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

برجاء المراجعة

الفلاشة.rar

تم تعديل أبريل 24, 2015 بواسطه صلاح الصغير

[لؤي الخزرجي]

سلمت يداكم

هذا هو المطلوب

 

تحياتي

[لؤي الخزرجي]

ا / عبد الله

 

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

برجاء المراجعة

 

 اخي العزيز

السلام عليكم

ان الملف يعمل بشكل رائع ولكن عندما انقل الكود الى الملف المراد عمل الحمايه له فأن خاصية الغلق عندما لايكون المايكرو مفعل لاتعمل

اي ان الملف يعمل في حالة تعطيل المايكرو

ارجو التوضيح

وشكرا

[صلاح الصغير]

ا / لؤى

للاسف انا عندى نفس المشكلة و هى دمج الاكواد

فارجو من الاساتذة افادتك فى هذا الموضوع

[دغيدى]

جميل .. جميل حقا

أثـــ  الله    ــــــــــابكم