اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


الردود الموصى بها

تفضل أخى

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

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

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

رابط هذا التعليق
شارك

  • 3 weeks later...

السلام عليكم

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

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

اولاً استخدم هذا الكود لقراءة رقم 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

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

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

رابط هذا التعليق
شارك

  • 1 year later...

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

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

لكن لى طلب بسيط هل يمكن تعديل الكود بحيث يسمح للملف بالفتح على 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

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

رابط هذا التعليق
شارك

السلام عليكم

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

هكذا


Sub code_HARD()

On Error Resume Next

With CreateObject("Scripting.FileSystemObject")

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

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

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

End With

End Sub

رابط هذا التعليق
شارك

السلام عليكم

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

رابط هذا التعليق
شارك

السلام عليكم

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


Sub code_HARD()

On Error Resume Next

With CreateObject("Scripting.FileSystemObject")

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

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

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

End With

End Sub

اخي الفاضل zarouki2000

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

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

رابط هذا التعليق
شارك

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

رابط هذا التعليق
شارك

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

تفضل أخى

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

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information