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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

الأول استخراج الرقم الثابت للهارد ديسك (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

تم تعديل بواسطه 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. كيف نستخدم رقم الهارد (إذا تأكدنا منه) فى تأمين ملف الغيكسيل بحيث لا يفتح إلا فقط فى الجهاز أو الأجهزة التى نحددها عن طريق رقم الهارد ديسك

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

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

استاذ يوسف

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

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

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

ثم Disk drives

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

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

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

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

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

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


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

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

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

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

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك

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

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

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

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

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

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

post-27378-0-58692100-1351707649_thumb.j

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

السلام عليكم

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

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

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

تم تعديل بواسطه عباد
رابط هذا التعليق
شارك

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

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

لاحظ أن

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

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

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

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

مع تحياتى

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

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

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

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

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

هل هذا ممكن ؟؟

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

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

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

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

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

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

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

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

الحمد لله

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

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

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

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

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

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

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

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


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

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

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

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

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

تم تعديل بواسطه ريان أحمد
رابط هذا التعليق
شارك

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

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

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

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

Omar_1.rar

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

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

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

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

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

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

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

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

أول نتيجة

12B1-CF33

بعد الفورمات

C04C-E2E2

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

GetPhysicalSerial()

أول نتيجة

WD-WMAVU2718655

بعد الفورمات

2020202057202d444d5756413255313736383535

تم تعديل بواسطه يوسف عطا
رابط هذا التعليق
شارك

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

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



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

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

Important Information