nono2011

السلام عليكم اخوتي الافاضل ... جربت البرنامج 70 مرة ولم يفتح لا بالعربية ولا الانجليزية ولا الفرنسية حتي لان الارقام على ما اعتقد ما يهم اللغة فهي تبقي ارقام .... الرجاء التاكد من اسم المستخدم وكلمة المرور ام الظاهر المشكل بجهازي مو راضي يفتح هالبرنامج الرهيب وخايف منه .... جزاكم الله خير .. افيدونا

للرفع ما يهم الارقام اخي

السلام عليكم كلمة المرور لم تفلح لا مع Admin ولا غيرها جربت ( pass123 ) الخاصة بـ Admin يطلع تحذير : تأكد من اسم المستخدم ونفس ( 123 )

السلام عليكم عمل جميل لكن كلمة المرور لا تشتغل لقد جربت كل اسما المستخدمين ولم تشتغل ( 123 ) شوف المشكل وجاوبنا اخي Jezea

السلام عليكم اخي mas123 اولا العمل رائع وأكثر .... سلمت يداك يا بطل ... ولكن عندي طلب : لماذا لا تجعل او تحول هذه الطريقة لملف اكسل بدل اكسس لنتعلم منها ونستفيد منها يا ريت تاخذ طلبي على محمل الجد وفقكم الله ويبقي العمل اكثر من روعة يا بطل

اقصد يضع الاسم الثاني بعد الخلية التي ينتهي بها تجميع الاسم الاول ليكن للاسم الاول 7 معطيات يعني يكون الاسم الثاني في السطر 8 وتقابله معلوماته هذا ما فهمته على ما اعتقد

شكرا اخي على الرد يضع الاسم الثاني تحته مباشرة وهكذا

السلام عليكم عندي سؤال عن كود ان امكن تجابوني عليه Sub ETAp() S = 9 M = 11 v = 23 For k = 11 To 60 For S = 9 To 39 If Sheets("Prof1").Range("h" & S) = Sheets("المعطيات").Range("br" & k) Then Worksheets("المعطيات").Range("bt:ce" & k).Copy Worksheets("Prof1").Select Range("h9").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=True End If Next k Next S End Sub تفاصيل الكود : عندي بيانات في ورقة اسمها المعطيات وورقة اسمها Prof1 يبحث في الورقة الثانية عن متغير ويحط مقاله جميع توابعه ( التي تتراوح من 1 إلي 12 ) حسب كل شخص ومتغير جربته وحاول وما اشتغل معي اين الخلل ياريت تصححولي الخطأ

السلام عليكم اخ علي صحيح ما قلته في مثالك وهو المطلوب

بدون تعليق ؟

السلام عليكم يوجد ملف ولا يوجد المطلوب ؟؟؟؟ كيف ياتري سيتم التعديل

السلام عليكم بما انني بدأت الموضوع لم يهنأ لي بال ولا خاطر فوجدت كود برمجي ارجو منكم تعديله أو تطويعه حسب المتطلبات -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

السلام عليكم سيدي المثال في الملف المرفق مع توضيح كما امرتم طلب.rar

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

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