يوسف عطا قام بنشر أكتوبر 28, 2012 مشاركة قام بنشر أكتوبر 28, 2012 أخوتى الأعزاء بالمنتدى عدة موضوعات بخصوص ربط عمل ملف الإيكسيل للعمل فقط على جهاز معين ولا يعمل الملف فى حالة نقله لجهاز آخر وذلك عن طريق إستخدام رقم البارتشن وكلنا يعلم أن رقم البارتشن يتغير مع عمل الفورمات إذن فالحل هو إستخدام رقم الهارد نفسه وهو رقم ثابت لا يتغير مع الفورمات أو خلافه وقد قام أحد الأخوة منذ فترة بعمل كود يقوم بإستخراج رقم الهارد وكتابته فى ملف الإكسيل ورغم أن الملف لم يعمل معى ربما لإختلاف نظام التشغيل ولكننى أريد من هنا إعادة فتح الموضوع لأهميته المطلوب كود يربط عمل الملف برقم الهارد بحيث لا يفتح الملف فى حالة نقله لجهاز آخر رابط هذا التعليق شارك More sharing options...
دغيدى قام بنشر أكتوبر 28, 2012 مشاركة قام بنشر أكتوبر 28, 2012 أخى الفاضل / يوسف تحية لكم على طرح هذا الموضوع الحيوى الموضوع له شقان . الأول استخراج الرقم الثابت للهارد ديسك (HD) والثانى ربط الرقم بالإكسيل أرسلت لأحد المواقع فكان الرد على الرابط التالى http://www.msofficegurus.com/post/Getting-the-hard-drives-serial-number-without-API-using-VBA.aspx رابط هذا التعليق شارك More sharing options...
خالد الشاعر قام بنشر أكتوبر 28, 2012 مشاركة قام بنشر أكتوبر 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 رابط هذا التعليق شارك More sharing options...
ريان أحمد قام بنشر أكتوبر 29, 2012 مشاركة قام بنشر أكتوبر 29, 2012 أخى الفاضل / يوسف تحية لكم على طرح هذا الموضوع الحيوى الموضوع له شقان . الأول استخراج الرقم الثابت للهارد ديسك (HD) والثانى ربط الرقم بالإكسيل أرسلت لأحد المواقع فكان الرد على الرابط التالى http://www.msofficegurus.com/post/Getting-the-hard-drives-serial-number-without-API-using-VBA.aspx السلام عليكم ذهبت الى الرابط فوجدت كود واحد أين أصعه وأين الكود الثاني رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 29, 2012 الكاتب مشاركة قام بنشر أكتوبر 29, 2012 للأسف لم تعمل معى الخيارات السابقة رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 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 رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 30, 2012 الكاتب مشاركة قام بنشر أكتوبر 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 بواسطه يوسف عطا رابط هذا التعليق شارك More sharing options...
خالد الشاعر قام بنشر أكتوبر 30, 2012 مشاركة قام بنشر أكتوبر 30, 2012 (معدل) استاذ يوسف هذا رقم الهرد الحقيقى WD-WMAVU2718655 لو نظرت الى الهارد الخاص بك سوف تلقى نفس هذا الرقم مكتوب على الهارد من الخارج او من Control Panel ثم System ثم Device Manager ثم Disk drives سوف تلقى الرقم الخاص بالهارد تم تعديل نوفمبر 1, 2012 بواسطه دغيدى رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 30, 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. يصمم الكود بطريقة معادلة إف بالبلدى كدة إذا كان الرقم فى خلية المعادلة متطابق مع الرقم أو أحد الأرقام الموجودة فى الكود ( مفروض أنها أرقام الهاردات التى مسموح فتح الملف بها) تظهر رسالة تفيد أنه جارى فتح الملف مع زر أوك وإن لم يتطابق الرقم فى المعادلة مع أحد الأرقام بالكود تظهر رسالة أن هذا الملف محظور فتحه على هذا الجهاز مع زر خروج ما رايكم فى هذا السيناريو للكود المطلوب علماً بأن رقم الهارد الذى يظهر فى الخلية التى بها المعادلة مفروض أن يتم تحديثه مع فتح الملف تلقائياً وقبل أن يعمل الكود ولكنه حتى الآن ومع الأسف لا يتم تحديثه إلا بعد ضغط إنتر فى الخلية الموجودة فيها المعادلة وفى إنتظار الحلول من الأعضاء المحترمين رابط هذا التعليق شارك More sharing options...
ريان أحمد قام بنشر أكتوبر 30, 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 رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 31, 2012 الكاتب مشاركة قام بنشر أكتوبر 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 رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 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 بواسطه عباد رابط هذا التعليق شارك More sharing options...
دغيدى قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 أخى الفاضل / أبو نصـــار كل عـــام وأنتم بخير ================== الصورة المرفقة لرقمين مختلفين الصورة السفلى عند وجود فلاشة والعليا بدون لاحظ الأرقام وقارن ثم قل لى رقم القرص الصلب ( الهارد ) رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 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 بواسطه عباد رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 31, 2012 الكاتب مشاركة قام بنشر أكتوبر 31, 2012 الأخ الغالى دغيدى بك الصورة السفلى توضح سيريال الفلاشة وكذلك سيريال الهارد لاحظ أن السطر الأول سيريال الفلاشة نصف السطر الثانى الأول نوع الفلاشة وماركتها وطريقة توصيلها نصف السطر الثانى الثانى سيريال الهارد السطر الثالث نوع الهارد وموديله وطريقة توصيله مع تحياتى رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 31, 2012 الكاتب مشاركة قام بنشر أكتوبر 31, 2012 أخى الغالى أبو نصار بالفعل الكود منع تشغيل الملف على الجهاز الذى لا يتوافق رقم هارده مع الأرقام فى الكود ولكن ببساطة يمكن فتح الملف على أى جهاز إذا تم تعطيل وحدات الماكرو ليكتمل الأمر لابد أن يوضع فى الكود جزء لتخفيض مستوى الأمان بالإيكسيل لأدنى درجة مع فتح الملف هل هذا ممكن ؟؟ رابط هذا التعليق شارك More sharing options...
دغيدى قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 أخى الفاضل / يوسف عطا ================== شكرا على ردكم وهذا ما لحظته ووضعت الصور ليستفد الكل أخى الفاضل / أبو نصـــار ================== الكود استخرج رقما واحدا فقط ( وليس رقمين ) مطابقا للرقم الذى استخرج من الكود الأول . رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 الحمد لله بالنسبة لجهازي اعطاني رقمين ومثل ماتفضلت الكود السابق نتائجه مطابقة للكود الاخير هو الهارد الفعلي للجهاز رابط هذا التعليق شارك More sharing options...
أبو آدم قام بنشر أكتوبر 31, 2012 مشاركة قام بنشر أكتوبر 31, 2012 إخوتي الفضلاء لست بينكم إلا طالب علم التمس بعض ما لديكم ولكن جُلّ ما استخدمتم يسرد أرقام المحركات الرئيسي منها والثانوي و المتحرك ، وندخل في التعداد لا الحصر أفضل حصر الأمر بمحرك الأقراص الرئيسي باستخدام شرط If objItem.DeviceID = "\\.\PHYSICALDRIVE0" Then وإدراج النتيجة في الكود ضمن متغير حيث نطلب التعامل مع PHYSICALDRIVE0 وهو يمثل دائماً (فيما أعلم ) محرك الأقراص الرئيسي والله أعلم ... وقد طبقت مثل ذلك في الأكسيس .... http://www.officena....showtopic=43842 أما أهل الإكسيل فأدرى بشعابها ... والله من وراء القصد وهو حسبي .............. رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر أكتوبر 31, 2012 الكاتب مشاركة قام بنشر أكتوبر 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 بواسطه يوسف عطا رابط هذا التعليق شارك More sharing options...
ريان أحمد قام بنشر نوفمبر 1, 2012 مشاركة قام بنشر نوفمبر 1, 2012 (معدل) لم ينجح الكود عندي والطريقة التي أعطيتها لي جربتها ولم تنجح والمشكلة عند تطبيق الكود ظهر ما يلي في الصورة المرفق44.rar تم تعديل نوفمبر 1, 2012 بواسطه ريان أحمد رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 1, 2012 الكاتب مشاركة قام بنشر نوفمبر 1, 2012 لا أعرف السبب بالضبط ولكن الملف عندى يعمل تماماً وقد جربته على أكتر من جهاز رابط هذا التعليق شارك More sharing options...
دغيدى قام بنشر نوفمبر 1, 2012 مشاركة قام بنشر نوفمبر 1, 2012 أخى الفاضل / khhanna رقم الهارد بالطريقة التى أشرت إليها فى المشاركة رقم 8 مختلف عن الرقم المستخرج بالكود رابط هذا التعليق شارك More sharing options...
ريان أحمد قام بنشر نوفمبر 5, 2012 مشاركة قام بنشر نوفمبر 5, 2012 هذا الكود لأحد عباقرة المنتدى للعثور على رقم الهارديسك الحقيقي المدون عله ولقد تأكدتم منه وذلك بشرط وضع الملف lمع المرفق في system 32 ------------------------------- الأن أريد أين أصع هذا الكود لكي يمنع دخول الملف في حالة تغيير الجهاز Omar_1.rar رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 8, 2012 الكاتب مشاركة قام بنشر نوفمبر 8, 2012 (معدل) قمت بالفورمات أمس وبتجربة الكود الذى يستخرج رقم الهارد ديسك فى ويندو برسالة إكتشفت أنه تغير أى أن هذا الكود لا يستخرج الرقم الحقيقى للهارد كما أن طريقة المعادلتان كذلك لم تعطيانى نفس الأرقام بعد الفورمات وإليكم الأرقام قبل وبعد الفورمات وكل معادلة المعادلة 1 HDSerialNumber() أول نتيجة 12B1-CF33 بعد الفورمات C04C-E2E2 المعادلة الثانية GetPhysicalSerial() أول نتيجة WD-WMAVU2718655 بعد الفورمات 2020202057202d444d5756413255313736383535 تم تعديل نوفمبر 8, 2012 بواسطه يوسف عطا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان