(تمت الاجابة) حماية وقفل ملف اكسل على رقم قرص صلب واحد

[nono2011]

السلام عليكم

جئتكم اليوم بفكرة طالما راودتني واحاول التعلم منكم :

1. كيف يمكن حماية برنامج اكسل : بحيث لا يشتغل إلا في جهاز معين – يعني قفل الملف على قرص صلب معين –
   

لنفرض مثلا أن رقم القرص الصلب : 22CB5-Az5899 ..

حيث لا يشتغل البرنامج إلا علي هذا الرقم والا يطلع له رسالة " عفوا هذا البرنامج غير مسجل "

2 – كيف يمكنني ربط ملف اكسل بقاعدة بيانات من نوع أكسس .

3 – طريقة ربط أو ملئ Combo Box من ورقة معينة في مجال محدد .

وشكرا

[عبدالله المجرب]

السلام عليكم

شاهد هذا الرابط

وان شاء الله تستفيد منه

http://www.officena.net/ib/index.php?showtopic=28561&hl=&fromsearch=1

[nono2011]

• أشكرك اخي على الرد ولكن السؤال عن الكود او الطريقة لحماية الملف بحيث لا يشتغل إلا في جهاز معين – يعني قفل الملف على قرص صلب معين –
  

بعد ان نكون استخرجنا رقم القرص الصلب

حيث لا يشتغل البرنامج إلا علي هذا الرقم والا يطلع له رسالة " عفوا هذا البرنامج غير مسجل "

ثم ماذا عن الاسئلة التالية :

2 – كيف يمكنني ربط ملف اكسل بقاعدة بيانات من نوع أكسس .

3 – طريقة ربط أو ملئ Combo Box من ورقة معينة في مجال محدد .

وشكرا

[عبدالله المجرب]

السلام عليكم

في الملف المرفق

عد الكود ليصبح هكذا

Sub GetMe()

Dim MySer As String * 99

Call GetSerialNumber(0, MySer)

[E5] = MySer

If [E5] <> "ضع هنا رقم القرص الصلب" Then

MsgBox "عفواً البرنامج غير مسجل", vbCritical, "تنبيه": Application.Quit

End If

End Sub

طبعاً لا تنسى ان تضع رقم القرص الصلب في المكان المحدد ثم ضع في حدث فتح الملف ThisWorkbook

Private Sub Workbook_Open()

RunMe

End Sub

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

اما بالنسبة للكمبوبوكس فمن خصائصه اذهب الى RowSource

ثم ضع المدى الذي ترغب بعد يساوي "="

[abouelhassan]

من القلب كل احترام استاذنا

100000 حمد الله على السلامة

تم تعديل ديسمبر 18, 2011 بواسطه abouelhssan

[عبدالله المجرب]

الله يسلمك ابو الحسن

وشكراً لك ولم استطيع ان اقاوم شغفي بحبكم وحب اوفيسنا

[الشهابي]

سلامات يا بو أحمد الله يحفظك من كل مكروه

[nono2011]

السلام عليكم

أخي عبد الله مشكور على الرد والاهتمام

ولكن يبقى سؤالي مطروح :

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

3 – طريقة ربط أو ملئ Combo Box من ورقة معينة في مجال محدد , وهنا أقصد Combo الذي في الفورم.

أنظر المرفق

وشكرا

تجربة.rar

[nono2011]

السلام عليكم

الفكرة واضحة أخ عبد الله ومشكور عليها .... لكن هل توجد طريقة أخري للتحقق من رقم القرص الصلب مباشر من المصدر System

وعدم ربطها بخلية معينة (E5) كما وضحت في مثالك

مع العلم انه كان عندي الطريقة وضيعتها للأسف

[الـعيدروس]

السلام عليكم

بعد اذن الاستاذ الحبيب عبدالله المجرب

اولاً استخدم هذا الكود لقراءة

رقم

ID الهارد

ثم اكتب الايدي في مذكرة

رقم

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

هذا الكود

Sub ALI_HARD()

With CreateObject("Scripting.FileSystemObject")

MsgBox Hex(.Drives.Item("c:").SerialNumber)

End With

End Sub

Private Sub Workbook_Open()

With CreateObject("Scripting.FileSystemObject")

If Hex(.Drives.Item("c:").SerialNumber) = "XXXX" Then

MsgBox "تفضل بالدخول"

Else: MsgBox "نأسف هذا البرنامج مخصص لجهاز اخر "

ThisWorkbook.Close savechanges = True

End If

End With

End Sub

وبعدها تحط ID في الشرط بدال الاكسات ( XXXX ) بهذا السطر

If Hex(.Drives.Item("c:").SerialNumber) = "XXXX" Then

الية الكود اذا حاولت استخدام الملف في جهاز اخر لن يفتح لان

رقم

الايدي غير مطابق

والسلام عليكم

وبعد حفظ

رقم

الايدي

حط هذا الكود في حدث ThisWorkbook

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

[nono2011]

السلام عليكم

سيدي شكرا لردك الجميل وتوضيحك الاروع .... منكم نتعلم ومنكم نستقي دمتم لنا ذخرا

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

استاذ alidroos

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

ولن يعمل هذا الكود

وسبق الاستاذ ابو تامر حل هذه المشكلة

وشكراً

[الـعيدروس]

الاخ الفاضل khhanna

إن امكن ترفق الحل كي نستفيد ويستفيد الاخوة

وفقك الله

[abouelhassan]

استاذنا ابو نصار روائع روائع

احترام وتقدير من اخيك

[ريان أحمد]

السلام عليكم

أولا ألف ألف حمدا لله كما ينبغي لجلال وجهه وعظمة سلطانه

على سلامتك يا أستاذنا عبد الله المجرب

الفكرة ككل جميلة جدا لكن عندي فكرة الرجاءتطبيقها إن أمكن

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

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

استاذ alidroos

الحل كما افاد الاخ عبد الله فى المشاركة 4

لحين ابداع حل اخر

شكراً

[بوحماد]

مشكورررررررررررررر

[nono2011]

السلام عليكم

بما انني بدأت الموضوع لم يهنأ لي بال ولا خاطر فوجدت كود برمجي ارجو منكم تعديله أو تطويعه حسب المتطلبات

-1- اولا هذا الكود لقراءة رقم القرص : ويوضع في ThisWorkbook

Private Sub rgbGetVolumeInformationRDI(PathName$, DrvVolumeName$, DrvSerialNo$)

    Dim r As Long

    Dim pos As Integer

    Dim HiWord As Long

    Dim HiHexStr As String

    Dim LoWord As Long

    Dim LoHexStr As String

    Dim VolumeSN As Long

    Dim MaxFNLen As Long

    Dim UnusedStr As String

    Dim UnusedVal1 As Long

    Dim UnusedVal2 As Long

    DrvVolumeName$ = Space$(14)

    UnusedStr$ = Space$(32)

    r& = GetVolumeInformation(PathName$, _

    DrvVolumeName$, Len(DrvVolumeName$), VolumeSN&, _

    UnusedVal1&, UnusedVal2&, UnusedStr$, Len(UnusedStr$))

    If r& = 0 Then Exit Sub

    'determine le label

    pos% = InStr(DrvVolumeName$, Chr$(0))

    If pos% Then DrvVolumeName$ = Left$(DrvVolumeName$, pos% - 1)

    If Len(Trim$(DrvVolumeName$)) = 0 Then DrvVolumeName$ = "(pas de label)"


    'determine l'id du disque

    HiWord& = GetHiWord(VolumeSN&) And &HFFFF&

    LoWord& = GetLoWord(VolumeSN&) And &HFFFF&


    HiHexStr$ = Format$(Hex(HiWord&), "0000")

    LoHexStr$ = Format$(Hex(LoWord&), "0000")


    DrvSerialNo$ = HiHexStr$ & "-" & LoHexStr$

End Sub

وهذا بقية الكود :

Function GetHiWord(dw As Long) As Integer

    If dw& And &H80000000 Then

	    GetHiWord% = (dw& \ 65535) - 1

    Else: GetHiWord% = dw& \ 65535

    End If

End Function

Function GetLoWord(dw As Long) As Integer

    If dw& And &H8000& Then

	    GetLoWord% = &H8000 Or (dw& And &H7FFF&)

    Else: GetLoWord% = dw& And &HFFFF&

    End If

End Function


Sub main()

Dim r&, PathName$, DrvVolumeName$, DrvSerialNo$

PathName$ = "c:\"

rgbGetVolumeInformationRDI PathName$, DrvVolumeName$, DrvSerialNo$

If DrvSerialNo$ <> "xxxx-xxxx" Then

ms1 = MsgBox(" " & Chr$(10) & Chr$(10) & "حذار !!! برنامج غير مرخص " & Chr$(10) & Chr$(10) _

& "إن محاولة إعادة تشغيله مرة أخرى" & Chr$(10) & Chr$(10) _

& "قد يتسبب في تعطيل جهازكم" & Chr$(10) & Chr$(10) _

& "للحصول على الترخيص إتصل " & Chr$(10) & Chr$(10) _

& "بصاحب البرنامج واطلب منه الترخيص" & Chr$(10) & Chr$(10) _

, vbOKOnly + vbExclamation + vbMsgBoxRight, "تحذير")

ActiveWorkbook.Save

ActiveWorkbook.Close

Else

ms2 = MsgBox(" " & Chr$(10) & Chr$(10) & "شكرا لك على اقتناء النسخة " & Chr$(10) & Chr$(10) _

& " المرخصة من المبرمج" & Chr$(10) & Chr$(10) _

& "بالتوفيق إن شاء الله" & Chr$(10) & Chr$(10) _

, vbOKOnly + vbInformation + vbMsgBoxRight, "شكر")

End If

End Sub

Private Sub workbook_open()

Worksheets("ضع اسم الورقة هنا").Activate


--------------------------جزء حماية ورقة معينة بكلمة سر ( كود ) - ----------------------------   

'protection de toutes les feuilles du document

Application.ScreenUpdating = False

	  Worksheets("ضع اسم الورقة هنا").Protect "xxxxxxx – ضع الكود الذي تريده"

  main

End Sub

-2- أما الجزء 2 فيوضع تحت ماكرو ( Modules ) سمه ما شئت وليكن مثلا : ProtictionNumDisk

Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" ( _

    ByVal lpRootPathName As String, _

    ByVal lpVolumeNameBuffer As String, _

    ByVal nVolumeNameSize As Long, _

    lpVolumeSerialNumber As Long, _

    lpMaximumComponentLength As Long, _

    lpFileSystemFlags As Long, _

    ByVal lpFileSystemNameBuffer As String, _

    ByVal nFileSystemNameSize As Long) As Long

حيث أن هذا الجزء هو المسؤول عن التحقق : و (xxxx-xxxx ) هو رقم القرص

If DrvSerialNo$ <> "xxxx-xxxx" Then

لكن المشكل عند الفرمتة ( فرمتة الجهاز ) يتغير رقم القرص ولا يعمل البرنامج لأن الرقم هو رقم البارتشين ( C ; D ; E ...... ) وليس رقم القرص الصلب الحقيقي

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

لاني جرب الطريقة التي أمامكم ولم تفلح بعدما فرمت الجهاز عن قصد فاضطررت لتغيير (xxxx-xxxx ) بالرقم الجديد

لذا أرجوا من الجميع ومن لديه خبرة أن يحاول لتعم الفائدة

هذا والله اعلم

وأخيرا أرفق لكم ملفين للتجربة والتمحيص

وفقنا الله وإياكم

تجربةSerial_No.rar

[ريان أحمد]

السلام عليكم

في الملف المرفق

عد الكود ليصبح هكذا

Sub GetMe()

Dim MySer As String * 99

Call GetSerialNumber(0, MySer)

[E5] = MySer

If [E5] <> "ضع هنا رقم القرص الصلب" Then

MsgBox "عفواً البرنامج غير مسجل", vbCritical, "تنبيه": Application.Quit

End If

End Sub

طبعاً لا تنسى ان تضع رقم القرص الصلب في المكان المحدد ثم ضع في حدث فتح الملف ThisWorkbook

Private Sub Workbook_Open()

RunMe

End Sub

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

اما بالنسبة للكمبوبوكس فمن خصائصه اذهب الى RowSource

ثم ضع المدى الذي ترغب بعد يساوي "="

بعد إذن الأستاذا عبد الله

بالنسبة للكود الذييوضع في ThisWorkbookjsتستبدل كلمة runme ب getme

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

الرجاء النظر في الكود لكي يسجل الخروج مباشرة

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

[عبدالله المجرب]

السلام عليكم

اخي طاهر هل وضعت رقم القرص الصلب بدل هذه العبارة

If [E5] <> "ضع هنا رقم القرص الصلب" Then

[ريان أحمد]

أولاالحمد لله على سلامتك

نعم وضعته

[احمدزمان]

السلام عليكم

ماشاء الله ابداعات جميله من العباقرة

دمتم بخير

[Akram Galal]

أستاذي الفاضل عبد الله المجرب

هل يمكن عمل الفكرة علي فورمة وليس في ورقة عمل

جزاك الله كل خير

[مصطفى السمري]

احبائي الكرام

 

لدي مشكلة في نقل الاكواد من ملف الى اخر

 

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

 

هل من مساعدة في هذا