اذهب الي المحتوي
أوفيسنا

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

  • 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

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

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

قام بنشر

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

قام بنشر

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

تفضل أخى

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

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

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

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

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information