( موضوع مميز) (تمت الاجابة)أريد كود يمنع الملف من الفتح عندما يستبدل جهاز الكمبيوتر--نقله-

[ريان أحمد]

السلام عليكم

أريد كود يمنع الملف من الفتح عندما يستبدل جهاز الكمبيوتر--نقله-

[دغيدى]

تفضل أخى

ملف من عمل أحد زملاء المنتدى ( نعتذر لعدم تذكر اسمه )

منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد

منع فتح الملف.rar

[ياسر الحافظ]

اخي وصديقي واستاذي " دغيدي "

والله انا مشتاق لك ...

جزاك الله كل الخير على اعمالك وردودك القيمة

وفقك الله

ابو الحارث

[بوحماد]

مشكور

[أبو العاصم]

طب ممكن كود لمنع نسخ الملف

يعنى يمنع عمل كوبى وبست لو هناك شرط فى الملف وهو مغلق

[الـعيدروس]

السلام عليكم

جزاك الله الف خير استاذ دغيدي

ولاثراء الموضوع هذا كود اخر

اولاً استخدم هذا الكود لقراءة رقم ID الهارد

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

هذا الكود

Sub code_HARD()

With CreateObject("Scripting.FileSystemObject")

MsgBox Hex(.Drives.Item("c:").SerialNumber)

End With

End Sub

وبعد حفظ رقم الايدي حط هذا الكود في حدث ThisWorkbook

Private Sub Workbook_Open()

With CreateObject("Scripting.FileSystemObject")

If Hex(.Drives.Item("c:").SerialNumber) = "F0E1D85C" Then

MsgBox "تفضل بالدخول"

Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر "

ThisWorkbook.Close savechanges = True

End If

End With

End Sub

استبدل الايدي الذي في الشرط بالايدي المحفوظ من هذا السطر المشار باللون الاحمر

If Hex(.Drives.Item("c:").SerialNumber) = "[color=#ff0000]F0E1D85C[/color]" Then

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

والسلام عليكم

[MAHMOUD ALI YOUSSEF]

السلام عليكم

اكواد قمة في الروعة

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

[zarouki2000]

الاخ ابو نصار الاخوة الافاضل السلام عليكم ورحمة الله و بركاته

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

لكن لى طلب بسيط هل يمكن تعديل الكود بحيث يسمح للملف بالفتح على 5 اجهزة يتم تحديدها من خلال رقم الهارد فى الكود

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

[الـعيدروس]

السلام عليكم

الاخ الفاضل zarouki2000

بعد إستخراج أرقام الأيدي للأجهزة

تحطها في المنغيرات PC

Private Sub Workbook_Open()

Dim PC1$, PC2$, PC3$, PC4$, PC5$

PC1 = "F0E1D85A" ' رقم الايدي للجهاز 1

PC2 = "F0E1D85B" ' رقم الايدي للجهاز 2

PC3 = "F0E1D85C" ' رقم الايدي للجهاز 3

PC4 = "F0E1D85D" ' رقم الايدي للجهاز 4

PC5 = "F0E1D85E" ' رقم الايدي للجهاز 5

With CreateObject("Scripting.FileSystemObject")

If Hex(.Drives.Item("c:").SerialNumber) = PC1 Or Hex(.Drives.Item("c:").SerialNumber) = PC2 _

Or Hex(.Drives.Item("c:").SerialNumber) = PC3 Or Hex(.Drives.Item("c:").SerialNumber) = PC4 _

Or Hex(.Drives.Item("c:").SerialNumber) = PC5 Then

MsgBox "تفضل بالدخول"

Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر "

ThisWorkbook.Close savechanges = True

End If

End With

End Sub

جرب الكود واخبرنا بالنتائج

[احمد حبيبه]

أخى أبو نصار كود رائع لكن لى طلب بسيط هل يمكن تعديل كود قراءة رقم ID الهارد بحيث يظهر فى خلية ممكن نسخ الكود منها بدلا من ظهوره فى MsgBox

[الـعيدروس]

السلام عليكم

فرضا الخلية هيا "A1"

هكذا

Sub code_HARD()

On Error Resume Next

With CreateObject("Scripting.FileSystemObject")

'*****************************************

[A1].Text = Hex(.Drives.Item("c:").SerialNumber)

'*****************************************

End With

End Sub

[احمد حبيبه]

أخى ابو نصار فعلت ما قلت واستبدلت الكود ولكن الكود لا يظهر فى الخلية

الكود.rar

[zarouki2000]

السلام عليكم

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

[الـعيدروس]

السلام عليكم

السموحه اخي احمد حبيب بيكون هكذا

Sub code_HARD()

On Error Resume Next

With CreateObject("Scripting.FileSystemObject")

'*****************************************

[C2].Value = Hex(.Drives.Item("c:").SerialNumber)

'*****************************************

End With

End Sub

اخي الفاضل zarouki2000

اشكرك جدا على مرورك العطر وكلامك المشجع

تقبلو تحياتي وشكري

[احمد حبيبه]

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

[أبو عبد النور]

السلام عليكم،

تفضل أخى

ملف من عمل أحد زملاء المنتدى ( نعتذر لعدم تذكر اسمه )

منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد

قمت يتحميل الملف ولكنني لم اجد به اي كود ؟

هل من الممكن رفعه من جديد للاطلاع عليه والاستفادة ؟

بارك الله فيكم.

[أبو عبد النور]

هل من متابعة للاستاذ دغيدي ؟