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

[يوسف عطا]

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

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

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

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

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

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

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

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

[دغيدى]

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

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

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

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

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

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

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

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

استاذ يوسف

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

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

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

[ريان أحمد]

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

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

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

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

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

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

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

السلام عليكم

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

[يوسف عطا]

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

[يوسف عطا]

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

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

[يوسف عطا]

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

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

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

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

الكود الأول

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

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 بواسطه يوسف عطا

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

استاذ يوسف

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

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

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

ثم Disk drives

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

تم تعديل نوفمبر 1, 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. يصمم الكود بطريقة معادلة إف

بالبلدى كدة

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

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

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

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

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

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

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

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

[ريان أحمد]

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

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

[يوسف عطا]

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

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

[الـعيدروس]

السلام عليكم

جرب هكذا

أرقام الأجهزة الفعليه تحطها في المتغيرات الثابته 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 بواسطه عباد

[دغيدى]

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

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

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

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

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

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

[الـعيدروس]

السلام عليكم

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

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

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

[يوسف عطا]

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

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

لاحظ أن

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

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

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

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

مع تحياتى

[يوسف عطا]

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

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

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

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

هل هذا ممكن ؟؟

[دغيدى]

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

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

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

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

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

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

[الـعيدروس]

الحمد لله

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

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

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

[أبو آدم]

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

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

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

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

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

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

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

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

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

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

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

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

[يوسف عطا]

أخى أبو نصار

لدى ملف به عدة أكواد في 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 بواسطه يوسف عطا

[ريان أحمد]

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

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

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

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

[يوسف عطا]

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

[دغيدى]

أخى الفاضل / khhanna

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

[ريان أحمد]

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

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

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

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

Omar_1.rar

[يوسف عطا]

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

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

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

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

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

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

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

أول نتيجة

12B1-CF33

بعد الفورمات

C04C-E2E2

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

GetPhysicalSerial()

أول نتيجة

WD-WMAVU2718655

بعد الفورمات

2020202057202d444d5756413255313736383535

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