مطلوب ربط الملف برقم الهارد نفسه وليس رقم البارتشن

**يوسف عطا** · أكتوبر 28, 2012

أخوتى الأعزاء

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

وكلنا يعلم أن رقم البارتشن يتغير مع عمل الفورمات

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

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

ورغم أن الملف لم يعمل معى ربما لإختلاف نظام التشغيل

ولكننى أريد من هنا إعادة فتح الموضوع لأهميته

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

**دغيدى** · أكتوبر 28, 2012

أخى الفاضل / يوسف

تحية لكم على طرح هذا الموضوع الحيوى

الموضوع له شقان .

الأول استخراج الرقم الثابت للهارد ديسك (HD)

والثانى ربط الرقم بالإكسيل

أرسلت لأحد المواقع فكان الرد على الرابط التالى

http://www.msofficegurus.com/post/Getting-the-hard-drives-serial-number-without-API-using-VBA.aspx

**خالد الشاعر** · أكتوبر 28, 2012

استاذ يوسف

هذه ملفات تعطى الرقم الحقيقيى للهرد

واحد يخص الاستاذ الكبير عمر الحسينى

http://www.officena.net/ib/index.php?showtopic=43174&hl=%D8%A7%D9%84%D9%87%D8%A7%D8%B1%D8%AF

و الاخر من على احد المواقع و هو معادلة تم طرحها على الموقع سابقاً

http://www.officena.net/ib/index.php?showtopic=43488&hl=%D8%A7%D9%84%D9%87%D8%A7%D8%B1%D8%AF

ويجب تصطيب ملف الكونفرد الخاص بالاوفس 2007

ارجو ان يكون المطلوب

Serial Good.rar

تم تعديل أكتوبر 28, 2012 بواسطه khhanna

**ريان أحمد** · أكتوبر 29, 2012

أخى الفاضل / يوسف

تحية لكم على طرح هذا الموضوع الحيوى

الموضوع له شقان .

الأول استخراج الرقم الثابت للهارد ديسك (HD)

والثانى ربط الرقم بالإكسيل

أرسلت لأحد المواقع فكان الرد على الرابط التالى

http://www.msofficegurus.com/post/Getting-the-hard-drives-serial-number-without-API-using-VBA.aspx

السلام عليكم

ذهبت الى الرابط فوجدت كود واحد أين أصعه وأين الكود الثاني

**يوسف عطا** · أكتوبر 29, 2012

للأسف لم تعمل معى الخيارات السابقة

**يوسف عطا** · أكتوبر 29, 2012

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


Function HDSerialNumber() As String

    Dim fsObj   As Object

    Dim drv	 As Object

    Set fsObj = CreateObject("Scripting.FileSystemObject")

    Set drv = fsObj.Drives("C")  

    HDSerialNumber = Left(Hex(drv.SerialNumber), 4) _

	    & "-" & Right(Hex(drv.SerialNumber), 4)

End Function

**يوسف عطا** · أكتوبر 30, 2012

إخوتى الأعزاء

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

عن طريق كودين مختلفين

وكل كود أعطانى نتيجة مختلفة

الكود الأول

يجب عمل التالى

1. نسخ الكود المرفق فى موديول


Function GetPhysicalSerial() As Variant

Dim obj As Object

Dim WMI As Object

Dim SNList() As String, i As Long, Count As Long

Set WMI = GetObject("WinMgmts:")

For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")

If obj.SerialNumber <> "" Then Count = Count + 1

Next

ReDim SNList(1 To Count, 1 To 1)

i = 1

For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")

SNList(i, 1) = obj.SerialNumber

i = i + 1

If i > Count Then Exit For

Next

GetPhysicalSerial = SNList

End Function

2. كتابة المعادلة التالية فى الخلية المراد إظهار رقم الهارد ديسك فيها


=GetPhysicalSerial()

ستجد رقم الهارد ديسك فى كل خلية تكتب فيها هذه المعادلة الكود الثانى الذى أخبرنا عنه أخونا جمال بك دغيدى فى مشاركته بالأعلى وبنفس الطريقة 1. نسخ الكود فى موديول


Function HDSerialNumber() As String

	 Dim fsObj As Object

	 Dim drv As Object

	 Set fsObj = CreateObject("Scripting.FileSystemObject")

	 Set drv = fsObj.Drives("C")

	 HDSerialNumber = Left(Hex(drv.SerialNumber), 4) _

			 & "-" & Right(Hex(drv.SerialNumber), 4)

End Function

2. كتابة المعادلة التالية فى الخلية المراد إظهار رقم الهارد ديسك فيها


=HDSerialNumber()

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

وبتجربة الكودين أعطيانى نتيجتين مختلفتين كما يلى

12B1-CF33 أعطتنى هذا الرقم HDSerialNumber

WD-WMAVU2718655 أعطتنى هذا الرقم GetPhysicalSerial

والآن لدينا مشكلتين

1. كيف نتأكد من رقم الهارد الثابت الأصلى الذى لا يتغير هل هو ما جلبه لنا الكود الأول أم ما جلبه لنا الكود الثانى ؟؟

2. كيف نستخدم رقم الهارد (إذا تأكدنا منه) فى تأمين ملف الغيكسيل بحيث لا يفتح إلا فقط فى الجهاز أو الأجهزة التى نحددها عن طريق رقم الهارد ديسك

وفى هذا فليدلى ذوى الخبرة كل منهم بدلوه فى هذا الموضوع

تم تعديل أكتوبر 30, 2012 بواسطه يوسف عطا

**خالد الشاعر** · أكتوبر 30, 2012

استاذ يوسف

هذا رقم الهرد الحقيقى WD-WMAVU2718655

لو نظرت الى الهارد الخاص بك سوف تلقى نفس هذا الرقم مكتوب على الهارد من الخارج

او من Control Panel ثم System ثم Device Manager

ثم Disk drives

سوف تلقى الرقم الخاص بالهارد

تم تعديل نوفمبر 1, 2012 بواسطه دغيدى

**يوسف عطا** · أكتوبر 30, 2012

حسناً يا أخوتى الأعزاء

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

ومرفق طريقة أخرى نتيجتها تظهر عن طريق رسالة داخل ويندو

وهى من الأخ حامد فله الشكر


Sub test()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

  For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

	    s = s & "SerialNumber: " & itm.SerialNumber & vbCrLf

	    s = s & "Model: " & itm.Model

  Next itm

End With

MsgBox s

End Sub

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


Function GetPhysicalSerial() As Variant

Dim obj As Object

Dim WMI As Object

Dim SNList() As String, i As Long, Count As Long

Set WMI = GetObject("WinMgmts:")

For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")

If obj.SerialNumber <> "" Then Count = Count + 1

Next

ReDim SNList(1 To Count, 1 To 1)

i = 1

For Each obj In WMI.InstancesOf("Win32_PhysicalMedia")

SNList(i, 1) = obj.SerialNumber

i = i + 1

If i > Count Then Exit For

Next

GetPhysicalSerial = SNList

End Function

2. وضع المعادلة فى بعض الخلايا بأحد شيتات الملف مع إخفاء هذا الشيت

3. يصمم الكود بطريقة معادلة إف

بالبلدى كدة

إذا كان الرقم فى خلية المعادلة متطابق مع الرقم أو أحد الأرقام الموجودة فى الكود ( مفروض أنها أرقام الهاردات التى مسموح فتح الملف بها)

تظهر رسالة تفيد أنه جارى فتح الملف مع زر أوك

وإن لم يتطابق الرقم فى المعادلة مع أحد الأرقام بالكود

تظهر رسالة أن هذا الملف محظور فتحه على هذا الجهاز مع زر خروج

ما رايكم فى هذا السيناريو للكود المطلوب

علماً بأن رقم الهارد الذى يظهر فى الخلية التى بها المعادلة مفروض أن يتم تحديثه مع فتح الملف تلقائياً وقبل أن يعمل الكود

ولكنه حتى الآن ومع الأسف لا يتم تحديثه إلا بعد ضغط إنتر فى الخلية الموجودة فيها المعادلة

وفى إنتظار الحلول من الأعضاء المحترمين

**ريان أحمد** · أكتوبر 30, 2012

السلام عليكم كيف ينجح معي هذا الكود

Sub test()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

s = s & "SerialNumber: " & itm.SerialNumber & vbCrLf

s = s & "Model: " & itm.Model

Next itm

End With

MsgBox s

End Sub

**يوسف عطا** · أكتوبر 31, 2012

السلام عليكم كيف ينجح معي هذا الكود

Sub test()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

s = s & "SerialNumber: " & itm.SerialNumber & vbCrLf

s = s & "Model: " & itm.Model

Next itm

End With

MsgBox s

End Sub

أولاً تضع الكود فى موديول

ثانياً تصنع زر لإستدعاء الكود

بمجرد كبس هذا الزر تظهر لك نتيجة الكود

الملف مرفق

إستخراج رقم الهارد ديسك.rar

**الـعيدروس** · أكتوبر 31, 2012

السلام عليكم

جرب هكذا

أرقام الأجهزة الفعليه تحطها في المتغيرات الثابته A,B,C

غيرها لايعمل البرنامج


Private Const A As String = "A12533225"

Private Const B As String = "B15223662"

Private Const C As String = "TOSHIBA MK6476GSX"

Private Sub Workbook_Open()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

	 s = s & itm.Model

Next itm

End With

If s = A Or s = B Or s = C Then

MsgBox "تم مطابقة الهارد بنجاح ", vbInformation, "تفضل بالدخول"

Else

MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج"

With ActiveWorkbook

.Close

.Saved = True

End With

Exit Sub

End If

End Sub

تم تعديل أكتوبر 31, 2012 بواسطه عباد

**دغيدى** · أكتوبر 31, 2012

أخى الفاضل / أبو نصـــار

كل عـــام وأنتم بخير

==================

الصورة المرفقة لرقمين مختلفين

الصورة السفلى عند وجود فلاشة والعليا بدون

لاحظ الأرقام وقارن ثم قل لى رقم القرص الصلب ( الهارد )

**الـعيدروس** · أكتوبر 31, 2012

السلام عليكم

استاذي الحبيب دغيدي حفظك الله

اعتقد الكود التالي يستخرج الهارد بصورة أدق

حيث انه يعطيك رقمين في خلية A1 و A2

الأول تنسخه مع الفراغ إن وجد في الخليه

وتلصقه في المتغير الثابت

والثاني تجاهله


Private Const A As String = "هنـــا"

هذا الكود لإستخراج رقم الهارد


Sub Ali_HD()

Dim Ali_Obj As Object

Dim Ali_Wm As Object

Dim Ali() As Variant

Dim i%, Csr%, T&

Set Ali_Wm = GetObject("WinMgmts:")

For Each Ali_Obj In Ali_Wm.InstancesOf("Win32_PhysicalMedia")

ReDim Preserve Ali(0 To i)

Ali(i) = Ali_Obj.SerialNumber

i = i + 1

Next

T = 1

For Csr = LBound(Ali) To UBound(Ali)

Cells(T, "A") = Ali(Csr)

T = T + 1

Next

Erase Ali

End Sub

وهذا الكود السابق في حدث Thisworkbook


Private Const A As String = "A12335644"

Private Const B As String = "Har Othr1"

Private Const C As String = "Har Othr2"

Private Sub Workbook_Open()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

  For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

	    s = s & itm.SerialNumber

  Next itm

End With

Debug.Print "C  :" & C & "  " & "s  :" & s

If s = A Or s = B Or s = C Then

MsgBox "تم مطابقة الهارد بنجاح ", vbInformation, "تفضل بالدخول"

Else

MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج"

With ActiveWorkbook

.Close

.Saved = True

End With

Exit Sub

End If

End Sub

تم تعديل أكتوبر 31, 2012 بواسطه عباد

**يوسف عطا** · أكتوبر 31, 2012

الأخ الغالى دغيدى بك

الصورة السفلى توضح سيريال الفلاشة وكذلك سيريال الهارد

لاحظ أن

السطر الأول سيريال الفلاشة

نصف السطر الثانى الأول نوع الفلاشة وماركتها وطريقة توصيلها

نصف السطر الثانى الثانى سيريال الهارد

السطر الثالث نوع الهارد وموديله وطريقة توصيله

مع تحياتى

**يوسف عطا** · أكتوبر 31, 2012

أخى الغالى أبو نصار

بالفعل الكود منع تشغيل الملف على الجهاز الذى لا يتوافق رقم هارده مع الأرقام فى الكود

ولكن ببساطة يمكن فتح الملف على أى جهاز إذا تم تعطيل وحدات الماكرو

ليكتمل الأمر لابد أن يوضع فى الكود جزء لتخفيض مستوى الأمان بالإيكسيل لأدنى درجة مع فتح الملف

هل هذا ممكن ؟؟

**دغيدى** · أكتوبر 31, 2012

أخى الفاضل / يوسف عطا

==================

شكرا على ردكم وهذا ما لحظته ووضعت الصور ليستفد الكل

أخى الفاضل / أبو نصـــار

==================

الكود استخرج رقما واحدا فقط ( وليس رقمين ) مطابقا للرقم الذى استخرج من الكود الأول .

**الـعيدروس** · أكتوبر 31, 2012

الحمد لله

بالنسبة لجهازي اعطاني رقمين

ومثل ماتفضلت الكود السابق نتائجه مطابقة للكود الاخير

هو الهارد الفعلي للجهاز

**أبو آدم** · أكتوبر 31, 2012

إخوتي الفضلاء

لست بينكم إلا طالب علم التمس بعض ما لديكم

ولكن جُلّ ما استخدمتم يسرد أرقام المحركات الرئيسي منها والثانوي و المتحرك ، وندخل في التعداد لا الحصر

أفضل حصر الأمر بمحرك الأقراص الرئيسي باستخدام شرط


If objItem.DeviceID = "\\.\PHYSICALDRIVE0" Then

وإدراج النتيجة في الكود ضمن متغير

حيث نطلب التعامل مع PHYSICALDRIVE0 وهو يمثل دائماً (فيما أعلم ) محرك الأقراص الرئيسي

والله أعلم ...

وقد طبقت مثل ذلك في الأكسيس .... http://www.officena....showtopic=43842

أما أهل الإكسيل فأدرى بشعابها ...

والله من وراء القصد وهو حسبي

..............

**يوسف عطا** · أكتوبر 31, 2012

أخى أبو نصار

لدى ملف به عدة أكواد في ThisWorkbook وعندما أردت إضافة الكود الذى أرفقته سيادتكم حدث تضارب مع الأكواد الأخرى

مرفق الأكواد برجاء التكرم بإيجاد حل لتعمل الأكواد الثلاثة معاً من نفس الحدث وكذلك أى كود جديد سنضيفه إلى الحدث فيما بعد


Private Const A As String = "	 WD-WMAVU2718655"

Private Const B As String = "2020202057202d444d5754413431343631363732"

Private Const C As String = "	 WD-WMAT14382851"

Private Sub Workbook_Open()

Dim s As String

With GetObject("winmgmts:\\.\root\CIMV2")

For Each itm In .ExecQuery("SELECT * FROM Win32_DiskDrive", , 48)

			 s = s & itm.SerialNumber

Next itm

End With

Debug.Print "C :" & C & " " & "s :" & s

If s = A Or s = B Or s = C Then

MsgBox "تم التأكد من الجهاز بنجاح ", vbInformation, "تفضل بالدخول"

Else

MsgBox "هذا البرنامج يعمل على أجهزة معينه فقط", vbInformation, "سيتم إغلاق البرنامج"

With ActiveWorkbook

.Close

.Saved = True

End With

Exit Sub

End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Sub Workbook_Open()

For i = 1 To Sheets.Count

Sheets("MyDate").Cells(3, i + 4) = Sheets(i).Name

Next

UserForm1.Show

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Private Sub Workbook_BeforeClose(Cancel As Boolean)

Sheets("1").Activate

For i = 2 To Sheets.Count

Sheets(i).Unprotect

Next

ThisWorkbook.Save

End Sub

تم تعديل نوفمبر 1, 2012 بواسطه يوسف عطا

**ريان أحمد** · نوفمبر 1, 2012

لم ينجح الكود عندي

والطريقة التي أعطيتها لي جربتها ولم تنجح

والمشكلة عند تطبيق الكود ظهر ما يلي في الصورة المرفق44.rar

تم تعديل نوفمبر 1, 2012 بواسطه ريان أحمد

**يوسف عطا** · نوفمبر 1, 2012

لا أعرف السبب بالضبط ولكن الملف عندى يعمل تماماً وقد جربته على أكتر من جهاز

**دغيدى** · نوفمبر 1, 2012

أخى الفاضل / khhanna

رقم الهارد بالطريقة التى أشرت إليها فى المشاركة رقم 8 مختلف عن الرقم المستخرج بالكود

**ريان أحمد** · نوفمبر 5, 2012

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

وذلك بشرط وضع الملف lمع المرفق في system 32

-------------------------------

الأن أريد أين أصع هذا الكود لكي يمنع دخول الملف في حالة تغيير الجهاز

Omar_1.rar

**يوسف عطا** · نوفمبر 8, 2012

قمت بالفورمات أمس

وبتجربة الكود الذى يستخرج رقم الهارد ديسك فى ويندو برسالة

إكتشفت أنه تغير

أى أن هذا الكود لا يستخرج الرقم الحقيقى للهارد

كما أن طريقة المعادلتان كذلك لم تعطيانى نفس الأرقام بعد الفورمات

وإليكم الأرقام قبل وبعد الفورمات وكل معادلة

المعادلة 1 HDSerialNumber()

أول نتيجة

12B1-CF33

بعد الفورمات

C04C-E2E2

المعادلة الثانية

GetPhysicalSerial()

أول نتيجة

WD-WMAVU2718655

بعد الفورمات

2020202057202d444d5756413255313736383535

تم تعديل نوفمبر 8, 2012 بواسطه يوسف عطا

تسجيل الدخول

مطلوب ربط الملف برقم الهارد نفسه وليس رقم البارتشن

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

يوسف عطا

دغيدى

خالد الشاعر

ريان أحمد

يوسف عطا

يوسف عطا

يوسف عطا

خالد الشاعر

يوسف عطا

ريان أحمد

يوسف عطا

الـعيدروس

دغيدى

الـعيدروس

يوسف عطا

يوسف عطا

دغيدى

الـعيدروس

أبو آدم

يوسف عطا

ريان أحمد

يوسف عطا

دغيدى

ريان أحمد

يوسف عطا

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information