نجوم المشاركات

تفضل هذا الحل بالإمكان تغيير وقت الإنصراف من خلال الكود نهاية الدوام الساعة 8 صباحا و بعدها سيتم حساب يوم جديد Public Function Overtime(RealCheckoutTime As Date, CheckoutTime As Date) Select Case CheckoutTime Case #1:00:00 AM# To #8:00:00 AM# Overtime = DateDiff("h", DateAdd("d", -1, RealCheckoutTime), CheckoutTime) Case Is > RealCheckoutTime Overtime = DateDiff("h", RealCheckoutTime, CheckoutTime) Case lese Overtime = 0 End Select End Function New Microsoft Access Database.accdb

انظر للمرفق..هل هذا ماتريده؟ AB.mdb

يعني قصدك في كل دورية تريد تحديث للمبلغ 17950 حسب الدفعات الجديدة .... صحيح .. اليس كذلك..

طيب ... ركز معي اخي الكريم هذا المرفق يعمل كالتالي :::: عند فتح نموذج التسليم .... اذا كانت الجمعية جديد يقوم البرنامج تلقائيا بتهيئة البيانات المطلوب وذلك بعد ظهور الرسالة التى تؤكد بدايتها اما اذا كان البرنامج به جمعية سابقة لم تنتهي فيعمل مباشرة دون اي رسائل واذا كان البرنامج به جمعية سابقة ولكن دورتها منتهية أي تم تسليم الجميع مستحقاتهم ... يقوم البرنامج تلقائيا بتجديد دورة اخر جديدة ======================================== ملاحظة هامة الاشخاص الذين تم استلامهم لاشهر سابقة لن تظهر اسمائهم في نموذج التسليم مرة اخرى ... حتى تستكمل الدورة للجميع ... ثم تعاد اسمائهم في الدورة الجديدة ======================================== امور فنية : الجدول المسمى distribution هو جدول لترحيل بيانات التسليم مع كل ضغطت زر للتسليم الجدول المسمى Kan_distribution هو جدول لوضع علامة امام كل مستلم حتى لايظهر اسمه قبل نهاية الدورة ..... ومع الدورة الجديد تزال تلك العلامات ========================================= انظر الصور .... مع تجربة المرفق .... وأعلمنا بالنتيجة الجمعية.accdb

اضافة المثال سهل الاجابة ..... بارك الله فيك أخي @Eng.Qassim

لكن فنيا : في عالم الجمعيات ... تعطى فترة محددة لجمعها وليست مفتوحة ... يعني مثلا بعد نزول الراتب باسبوع مثلا ... ليش لان المستلم الى عليه الدور يبغى فلوسه كاملة وليس مقسطه .... لكن تفضل التعديل حسب طلبك .... الجمعية (4).accdb ايضا نسيت .... المفروض البيانات الاساسية تكون في جدول مستقل ..... وبيانات الدفع تكون في جدول اخر بحيث تسجل فيها بيانات الدفع وطرقة الدفع والشهر ايضا ... هناك ملاحظات نسيتها الان ... اذا تذكرتها اضيفها

إن شاء الله يكون هذا هو المطلوب تم إخراج الترحيل لشيت حجوزات من شرط عدم فراغ txt3 ' ليدجر - حجوزات ترحيل Application.ScreenUpdating = FALSE Dim answer As Integer answer = MsgBox("ترغب فى ادخال هذه البيانات", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation") If answer = vbYes Then If Txt3 <> "" Then Dim rng1 As Range Dim str_search As String str_search = Txt3.Value Set rng1 = Sheets("ليدجر").Range("E:E").Find(str_search, , xlValues, xlWhole) Dim row_number As Long row_number = rng1.Row Dim lastcolumn As Long lastcolumn = IIf(Sheets("ليدجر").Range("lu" & row_number) = "", 333, Sheets("ليدجر").Range("lu" & row_number).End(xlToRight).Column + 1) Sheets("ليدجر").Cells(row_number, lastcolumn).Value = C3.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 1).Value = CDate(C4) Sheets("ليدجر").Cells(row_number, lastcolumn + 2).Value = C5.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 3).Value = C6.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 4).Value = C7.Value 'Sheets("ليدجر").Select Cells(row_number, lastcolumn).Select End If Dim lastrow As Long lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row lastrow = lastrow + 1 With ThisWorkbook.Sheets("حجوزات") .Range("H" & lastrow).Value = Txt50.Value .Range("I" & lastrow).Value = Txt3.Value .Range("D" & lastrow).Value = TXT1.Value .Range("G" & lastrow).Value = CDate(TXT2) .Range("F" & lastrow).Value = Txt8.Value .Range("K" & lastrow).Value = Txt18.Value .Range("M" & lastrow).Value = Txt28.Value .Range("N" & lastrow).Value = Txt31.Value 'كود مسح البيانات Me.Txt50.Value = "" Me.Txt3.Value = "" Me.TXT1.Value = "" Me.TXT2.Value = "" Me.Txt8.Value = "" Me.Txt18.Value = "" Me.Txt28.Value = "" Me.Txt31.Value = "" End With End If Application.ScreenUpdating = True MsgBox "تم الترحيل بنجاح" بالتوفيق

انظر هنا لاستاذنا القدير محمد صالح وايضا هنا مع مثال عملي للاستاذ احمد سليم

اذن كيف تريد منع التكرار في الجدول ...... اذن هناك لبس في الموضوع .... لو ارفقت مثال لعرفنا وانتهى الموضوع ..... لان تفسيراتنا الغيبية انت تتحدث في جانب ونحن في جانب .... لن نصل ونضيع الوقت !!

وبارك فيك ...

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

اخي الكريم ليس بالضرورة وجود مفتاح رئيسي في الجدول ........ انظر هذا الجدول ....

اجعل احد حقول الجدول حسب الصورة ....

اين الحروف في المثال ؟؟؟؟ على كل حال انظر المرفق .... مثال.rar

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

طيب اخي الكريم جرب المرفق ووافينا بالنتيجة .... علما اننا اضفنا حقل نعم / لا في الجدول A AB.mdb

مشاركة مع استاذ قاسم تفضل التعديل ارجو ان يكون طلبك برنامج الديون-1.rar

يفضل البدء بموضوع جديد بعنوان جديد مادام المطلوب مختلف هذا الموضوع يحتوي على ثلاثة مطلوبات أو أربعة على كل حال ضع قبل نهاية الإجراء مباشرة Me.TextBox2 = i2 بالتوفيق

بالضبط كده الحمد لله جزاكم الله الف خير

بما ان الضرب في 24 يجلب التاريخ مع الوقت وليس الوقت فقط نجرب استعمال دالة hour الاضافي: hour(000) حيث 000 هي المعادلة القديمة بالتوفيق

شكرا لك استاذي العزيز @kanory فمنكم نتعلم

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

وعليكم السلام-لا يمكن العمل على التخمين ... ارفع من فضلك ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة وشكراً !!!!

شكرا استاذ محمد الكود يعمل بنجاح جزاك الله خيرا

If Txt3 <> "" Then --------- --------- Else GoTo NXT End If NXT: Dim lastrow As Long

عليكم السلام المشكلة عندك في النموذج المخفي ، لم اضع يدي على الخلل ، ولكني قمت باستبدال النموذج . وعملت كودا صغيرا للاختبار ، فجعلت ظهور الرسالة كل خمس ثواني بدلا من الغلق الأمر يعمل عند معاينة التقرير exit.rar

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

رائع جدا جدا،، سلمت رعاك الله،،

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

company LTD.xlsx

انت لو سألت سؤال محدد لوجدت الف اجابة !!!!

لا أعتقد أن هذا هو المطلوب @د.كاف يار لأن النتيجة المطلوبة على. ترتيب السجلات هي 5 0 0 8 4 والحمد لله تم تحققها في معادلتي

الشكر لله أخي الكريم يبدو أنك ما لاحظت أن المسلسل بعد 1009 هو 1010 وليس 10010 أو ربما يكون التسلسل الصحيح يقفز من 1009 إلى 10010 وحضرتك نسيت وكتبت التسلسل كما بالصورة المأخوذة من ملفك بنيت فكرتي في الحل على مسلسل الرقم والكود وليس على الفكرة الموجودة في الملف وهي دمج الرقم مع 100 نظرا لعدم موافقتها للتسلسل خالص دعواتي بالتوفيق

بعد إذن صديقي العزيز @Ali Mohamed Ali هذه الحيلة لن تفيد مع دمج الرقم 100 مع 10 لأن الناتج سيكون 10010 عشرة آلاف وعشرة وليس 1010 لذا أقترح وضع هذه المعادلة في C1 =SUM(1000,A1) وفي هذه الحالة يمكن الاستغناء عن العمود B مرفق الملف بعد التعديل ليتناسب مع الأرقام بعد 9 بالتوفيق TEST.xlsx

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

طيب مشاركة مع حبايبنا الاساتذة ..... اظن هذه معروفة ..... صح ..... Private Sub BtnFalse_Click() ChkBox = False ChkBox.Requery DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t2 SET t2.[YesNo] = [Forms]![incom2]![ChkBox] WHERE (((t2.xuser)=[Forms]![incom2]![xuser]));" DoCmd.SetWarnings True End Sub Private Sub BtnTrue_Click() ChkBox = True ChkBox.Requery DoCmd.SetWarnings False DoCmd.RunSQL "UPDATE t2 SET t2.[YesNo] = [Forms]![incom2]![ChkBox] WHERE (((t2.xuser)=[Forms]![incom2]![xuser]));" DoCmd.SetWarnings True End Sub

طيب اخي الكريم انت تقول غير اسم التقرير في الكود ..... وتريد ان معالج اختيار مكان الحفظ استخدم هذا الكود ...... DoCmd.OutputTo acOutputQuery, "rpt_Items_Dates_3", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint

اظن الحالة الاولى .... معروفة وسهلة هذا مثال للحالة الثانية ...... Bar_te.accdb

هل تريد ذلك عن طريق المبرمج أم المستخدم هو من يتحكم ؟؟؟؟ اذا كان كمبرمج ..... فيمكن ذلك عن طريق عمل استعلام للجدول المطلوب وتحديد الحقول المطلوبة للتصدير .... ثم تصدير الاستعلام بدل الجدول ... وإذا كان كمستخدم ..... فيمكن ذلك عن طريق عمل فورم يجلب الجداول في كمبوبكس ... ثم اظهار الحقول الخاصة بالجدول بعد اختياره .... ثم تصدير الحقول المختارة فقط ... ماذا تريد انت ؟؟؟؟؟؟؟؟؟

تلميذك ..... منك نتعلم

تفضل ...... Output_Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Date, "dd-mm-yyyy") & ".xlsx" DoCmd.OutputTo acOutputQuery, "qry_Query", "ExcelWorkbook(*.xlsx)", Output_Path, False, "", , acExportQualityPrint

مادام التقرير يخص موظفا في شهر معين فلا داعي للتقرير ويمكن الاعتماد على عملية التصفية (فلتر) في نفس شيت الشهر مع تعديل المعادلات لتتناسب مع المطلوب . تم ضبط مجموعة المعادلات في خلايا التأخير وما بعدها والتنسيق الشرطي ووضع معادلة ( إجمالي وعدد) الموظف المختار أو الكل حسب الفلتر ويمكن الاستغناء عن صف المجموع أسفل البيانات بالتوفيق حضور وانصراف الموظفين 111.xlsx

No way without using VBA

اخى الكريم omaryoseeg بعد السلام عليكم ارجو ان يفى الملف التالى بالغرض وحده الطباعه2016.rar

السلام عليكم ورحمة الله وبركاته . وهذا كود اخر لا علاقه له بالتاريخ , وانما يعتمد على عدد مرات فتح البرنامج وبعد انتهاء العدد المسموح به تخرج رساله تنبهك بشراء البرنامج . بالضبط كالبرامج التي تباع بالانترنيت تستطيع فتحها لمدة مرتين فقط . لكن هنا في الكود جعلت عدد مرات فتح البرنامج 100 مرة . Private Sub Form_Current() retvalue = GetSetting("A", "0", "Runcount") GD$ = Val(retvalue) + 1 SaveSetting "A", "0", "RunCount", GD$ If GD$ > 100 Then MsgBox ("انتهت مدة تشغيل البرنامج عليك بشراء البرنامج او الاتصال بالمطور"), , ("AZHAR ALIraqy") DoCmd.Quit End If End Sub

اخى عيسى جرب الكود الاتى TextBox5 = Me.ListBox1.ListCount

أخي apt عذرا، لكني حاولت أن أجد وسيلة لتطبيق الخط دون تنصيبه، ولكن لا توجد طريقة لذلك. فيجب تنصيب الخط لكي تتمكن من التحكم فيه. تجد مرفقا ملف الخط الذي اسميته circ. لتنصيب الخط، قم بتنزيله أولا إلى جهازك، إلى سطح المكتب مثلا. بعد ذلك افتح مجلد الخطوط بهذه الطريقة السريعة: اضغط Start (ابدأ) ثم Run (ما أظن أن ترجمته هي تشغيل...). اكتب كلمة fonts في المربع ثم اضغط على OK (موافق). سيفتح عندئذ مربع الخطوط. بعد ذلك اسحب الخط إلى داخل المربع، وعندئذ يقوم الويندوز بتنصيب الخط circ. افتح مستند الوورد وحدد القائمة التي تريد أن ترقم مندرجاتها بأرقام مدورة. من قائمة format (تنسيق) اختر Bullets and Numbering (تعداد نقطي وتعداد رقمي) ثم علامة التبويب Numbered (تعداد رقمي). اختر منها التعداد الأجنبي ABCD (الأحرف الكبيرة)، ثم اضغط على Customize (تخصيص). في خانة Number format (تنسيق الأرقام) احذف النقطة (إذا وُجدت) من أمام الحرف. ثم اضغط على زر Font (الخط). وتحت Latin text font (خط النص اللاتيني) اختر الخط circ ثم اضغط على موافق مرتين لإغلاق المربعين. وهكذا يتبع الوورد التعداد المستند على الخط circ الذي فيه ABC إلخ هي 1 و 2 و3... مدورة. ملاحظة هامة: لا ينفع هذا الخط إلا لهذا النوع من التعداد. فإذا أردت إجراء تعداد من نوع آخر، فعليك استعمال خط من الخطوط المنصبة أصلا على كمبيوترك. ملاحظة هامة ثانية: لسبب ما لم يسمح لي المنتدى برفع ملف الخط، لذلك قمتُ بتغيير امتداده إلى doc. بعد أن تقوم بالتنزيل، غير الامتداد من doc إلى ttf. وكما قلت، يفيدك هذا التعداد حتى الرقم 26. circ.doc

أخي الكريم : أبوعبدالله2 لنفترض أنك في برنامجك يلزم لك تخزين عدد مرات تشغيل برنامجك .. وأن الاسم الذي ترغب بإكلاقه على برنامجك هو "المعين لحل المعالات الرياضية" وأن اسم المتحول الذي ستستخدمه لتخزين عدد مرات تشغيل البرنامج هو repetition حسناً .. عند تشغيل البرنامج وعند فتح الفورم الرئيسي نكتب ما يلي : repetition = GetSetting "المعين لحل المعالات الرياضية","Var","Repet No",0 لا حظ أن : "Repet NO" هو اسم كيفي استخدمته للدلالة على هذه القيمة التي أقرؤها .. ويدعى هذا الاسم بـ ( مفتاح ) رقم 0 : هو القيمة الافتراضية التي سيعيدها هذا التابع في حال لم نكن قد خزنا من قبل قيمة لهذا المفتاح ، أي عند أول استخدام للبرنامج سيعيد لنا تابع GetSetting القيمة صفر ثم نكتب بعد سطر التعليمات السابق ما يلي : Repetition = Repetition + 1 SaveSetting "المعين لحل المعالات الرياضية","Var","Repet No",Repetion وبهذان السطران نكون قد زدنا على قيمة المتحول Repetition قيمة +1 ثم قمنا بتخزينه مكان القيمة السابقة له

تتطلب تعليمة saveSetting أربع ممرات : اسم التطبيق اسم مجموعة الخيارات اسم الشيء المطلوب تخزين قيمته (المفتاح) قيمته مثال : SaveSetting "MyApp","Startup", "Left", 50 ولقراءة القيمة نستخدم GetSetting بنفس الممرات السابقة الثلاث الأولى وتكون الممررة الرابعة(اختياراية) هي القيمة الافتراضية (في حال عدم وجود هذا المفتاح في الريجستري) مثال : MyLeftvalue = GetSetting "MyApp","Startup", "Left", 25

حفظ المعلومات في الريجستي يكون باستخدام SaveSetting كالتالي : SaveSetting "اسم التطبيق","اسم القسم","المفتاح","القيمة" مثال : SaveSetting "برنامجي", "نموذج الخيارات", "إظهار حقل", مربع_التدقيق_الأول والإستعادة أو القراءة تكون باستخدام GetSetting كالتالي : متغير= GetSetting ("اسم التطبيق","اسم القسم","المفتاح") مثال : مربع_التدقيق_الأول= GetSetting("إظهار حقل", "نموذج الخيارات", "برنامجي") ولايوجد في هذه الطريقة أي مشاكل نهائياً ، وقد طبقت ذلك في عدة برامج واستخدمه خاصة في خيارات المستخدم في القاعدة . وبإمكانك وضع قيم افتراضيه حالما يتم تحميل النموذج عندما لايجد قيم مسجله في الريجستي وللتأكد من عدم وجود قيمة استخدم : If GetSetting("اسم التطبيق", "اسم القسم", "المفتاح") = "" Then وإذا استخدمت متغير فاجعل من نوع Variant أو String . فائدة : ولحذف إدخال في سجل (للمثال السابق) : 1- لكافة التطبيق : DeleteSetting "برنامجي" 2- لحذف قسم واحد فقط : DeleteSetting "برنامجي","نموذج الخيارات" 3- لحذف إدخال واحد فقط : DeleteSetting "إظهار حقل", "نموذج الخيارات", "برنامجي" فائدة : لفتح ملف التسجيل لمعاينة التغييرات ؛ انقر ابدأ ثم تشغيل واكتب RegEdit وانتقل إلى HKEY_CURRENT_USER\Software\VB and VBA Program Settings وستجد اسم التطبيق انقر عليه وستجد الأقسام التي وضعتها داخل اسم التطبيق . ملاحظة هامة جداً : كن حذراً جداً من أي تغيير في السجل لاتعرف تأثيره لأنه قد يؤدي إلى في أسوأ الأحوال إلى توقف الوندوز عن العمل وفي أقلها تعطل بعض البرامج أو الخيارات أو غيرها . ------------------ وهذا الكود يمكنك من القراءة والكتابة وحذف قيمة من مفتاح مع ملاحظة أنه يمكن تخزين القيم وإنشاء مفاتيح تحت أحد الجذور الأربعة التالية لملف الريجستي : HKeyClassesRoot HKeyCurrentUser HKeyLocalMachine HKeyUsers والان اليكم الكود : Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Declare Function RegCloseKey _ Lib "advapi32.dll" _ (ByVal lngHKey As Long) _ As Long Private Declare Function RegCreateKeyEx _ Lib "advapi32.dll" _ Alias "RegCreateKeyExA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String, _ ByVal Reserved As Long, _ ByVal lpClass As String, _ ByVal dwOptions As Long, _ ByVal samDesired As Long, _ ByVal lpSecurityAttributes As Long, _ phkResult As Long, _ lpdwDisposition As Long) _ As Long Private Declare Function RegOpenKeyEx _ Lib "advapi32.dll" _ Alias "RegOpenKeyExA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ phkResult As Long) _ As Long Private Declare Function RegQueryValueExString _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As String, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExLong _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExBinary _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExNULL _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegSetValueExString _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ ByVal lpValue As String, _ ByVal cbData As Long) _ As Long Private Declare Function RegSetValueExLong _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ lpValue As Long, _ ByVal cbData As Long) _ As Long Private Declare Function RegSetValueExBinary _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ ByVal lpValue As Long, _ ByVal cbData As Long) _ As Long Private Declare Function RegEnumKey _ Lib "advapi32.dll" _ Alias "RegEnumKeyA" _ (ByVal lngHKey As Long, _ ByVal dwIndex As Long, _ ByVal lpName As String, _ ByVal cbName As Long) _ As Long Private Declare Function RegQueryInfoKey _ Lib "advapi32.dll" _ Alias "RegQueryInfoKeyA" _ (ByVal lngHKey As Long, _ ByVal lpClass As String, _ ByVal lpcbClass As Long, _ ByVal lpReserved As Long, _ lpcSubKeys As Long, _ lpcbMaxSubKeyLen As Long, _ ByVal lpcbMaxClassLen As Long, _ lpcValues As Long, _ lpcbMaxValueNameLen As Long, _ ByVal lpcbMaxValueLen As Long, _ ByVal lpcbSecurityDescriptor As Long, _ lpftLastWriteTime As FILETIME) _ As Long Private Declare Function RegEnumValue _ Lib "advapi32.dll" _ Alias "RegEnumValueA" _ (ByVal lngHKey As Long, _ ByVal dwIndex As Long, _ ByVal lpValueName As String, _ lpcbValueName As Long, _ ByVal lpReserved As Long, _ ByVal lpType As Long, _ ByVal lpData As Byte, _ ByVal lpcbData As Long) _ As Long Private Declare Function RegDeleteKey _ Lib "advapi32.dll" _ Alias "RegDeleteKeyA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String) _ As Long Private Declare Function RegDeleteValue _ Lib "advapi32.dll" _ Alias "RegDeleteValueA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String) _ As Long Public Enum EnumRegistryRootKeys HKeyClassesRoot = &H80000000 HKeyCurrentUser = &H80000001 HKeyLocalMachine = &H80000002 HKeyUsers = &H80000003 End Enum Public Enum EnumRegistryValueType rrkRegSZ = 1 rrkregbinary = 3 rrkRegDWord = 4 End Enum Private Const mcregOptionNonVolatile = 0 Private Const mcregErrorNone = 0 Private Const mcregErrorBadDB = 1 Private Const mcregErrorBadKey = 2 Private Const mcregErrorCantOpen = 3 Private Const mcregErrorCantRead = 4 Private Const mcregErrorCantWrite = 5 Private Const mcregErrorOutOfMemory = 6 Private Const mcregErrorInvalidParameter = 7 Private Const mcregErrorAccessDenied = 8 Private Const mcregErrorInvalidParameterS = 87 Private Const mcregErrorNoMoreItems = 259 Private Const mcregKeyAllAccess = &H3F Private Const mcregKeyQueryValue = &H1 Public Sub RegistryCreateNewKey( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String) Dim lngRetVal As Long Dim lngHKey As Long On Error GoTo PROC_ERR lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _ mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&) If lngRetVal = mcregErrorNone Then RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryCreateNewKey" Resume PROC_EXIT End Sub Public Sub RegistryDeleteKey( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String) Dim lngRetVal As Long On Error GoTo PROC_ERR ' Delete the key lngRetVal = RegDeleteKey(eRootKey, strKeyName) PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryDeleteKey" Resume PROC_EXIT End Sub Public Sub RegistryDeleteValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String) Dim lngRetVal As Long Dim lngHKey As Long On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) ' If the key was opened successfully, then delete it If lngRetVal = mcregErrorNone Then lngRetVal = RegDeleteValue(lngHKey, strValueName) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryDeleteValue" Resume PROC_EXIT End Sub Public Sub RegistryEnumerateSubKeys( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ astrKeys() As String, _ lngKeyCount As Long) Dim lngRetVal As Long Dim lngHKey As Long Dim lngKeyIndex As Long Dim strSubKeyName As String Dim lngSubkeyCount As Long Dim lngMaxKeyLen As Long Dim typFT As FILETIME On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) If lngRetVal = mcregErrorNone Then 'find the number of subkeys, and redim the return string array lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, lngSubkeyCount, _ lngMaxKeyLen, 0, 0, 0, 0, 0, typFT) If mcregErrorNone = lngRetVal Then If lngSubkeyCount > 0 Then ReDim astrKeys(lngSubkeyCount - 1) As String 'set up the while loop lngKeyIndex = 0 ' Pad the string to the maximum length of a sub key, plus 1 for null ' termination lngMaxKeyLen = lngMaxKeyLen + 1 strSubKeyName = Space$(lngMaxKeyLen) Do While RegEnumKey(lngHKey, lngKeyIndex, strSubKeyName, lngMaxKeyLen + 1) = 0 ' Set the string array to the key name, removing null termination If InStr(1, strSubKeyName, vbNullChar) > 0 Then astrKeys(lngKeyIndex) = Left$(strSubKeyName, InStr(1, strSubKeyName, _ vbNullChar) - 1) End If ' Increment the key index for the return string array lngKeyIndex = lngKeyIndex + 1 Loop End If ' return the new dimension of the return string array lngKeyCount = lngSubkeyCount End If ' Close the key RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryEnumerateSubKeys" Resume PROC_EXIT End Sub Public Sub RegistryEnumerateValues( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ astrValues() As String, _ lngValueCount As Long) Dim lngRetVal As Long Dim lngHKey As Long Dim lngKeyIndex As Long Dim strValueName As String Dim lngTempValueCount As Long Dim lngMaxValueLen As Long Dim typFT As FILETIME On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) If lngRetVal = mcregErrorNone Then 'find the number of subkeys, and redim the return string array lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, 0, _ 0, 0, lngTempValueCount, lngMaxValueLen, 0, 0, typFT) If mcregErrorNone = lngRetVal Then If lngTempValueCount > 0 Then ReDim astrValues(lngTempValueCount - 1) As String 'set up the while loop lngKeyIndex = 0 ' Pad the string to the maximum length of a sub key, plus 1 for null ' termination lngMaxValueLen = lngMaxValueLen + 1 strValueName = Space$(lngMaxValueLen) Do While RegEnumValue(lngHKey, lngKeyIndex, strValueName, _ lngMaxValueLen + 1, 0, 0, 0, 0) = 0 ' Set the string array to the key name, removing null termination If InStr(1, strValueName, vbNullChar) > 0 Then astrValues(lngKeyIndex) = Left$(strValueName, InStr(1, strValueName, _ vbNullChar) - 1) End If ' Increment the key index for the return string array lngKeyIndex = lngKeyIndex + 1 Loop End If ' return the new dimension of the return string array lngValueCount = lngTempValueCount End If ' Close the key RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryEnumerateValues" Resume PROC_EXIT End Sub Public Function RegistryGetKeyValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String) _ As Variant Dim lngRetVal As Long Dim lngHKey As Long Dim varValue As Variant Dim strValueData As String Dim abytValueData() As Byte Dim lngValueData As Long Dim lngValueType As Long Dim lngDataSize As Long On Error GoTo PROC_ERR varValue = Empty lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0&, mcregKeyQueryValue, _ lngHKey) If mcregErrorNone = lngRetVal Then lngRetVal = RegQueryValueExNULL(lngHKey, strValueName, 0&, lngValueType, _ 0&, lngDataSize) If lngRetVal = mcregErrorNone Then Select Case lngValueType ' String type Case rrkRegSZ: If lngDataSize > 0 Then strValueData = String(lngDataSize, 0) lngRetVal = RegQueryValueExString(lngHKey, strValueName, 0&, _ lngValueType, strValueData, lngDataSize) If InStr(strValueData, vbNullChar) > 0 Then strValueData = Mid$(strValueData, 1, InStr(strValueData, _ vbNullChar) - 1) End If End If If mcregErrorNone = lngRetVal Then varValue = Left$(strValueData, lngDataSize) Else varValue = Empty End If ' Long type Case rrkRegDWord: lngRetVal = RegQueryValueExLong(lngHKey, strValueName, 0&, _ lngValueType, lngValueData, lngDataSize) If mcregErrorNone = lngRetVal Then varValue = lngValueData End If ' Binary type Case rrkregbinary If lngDataSize > 0 Then ReDim abytValueData(lngDataSize) As Byte lngRetVal = RegQueryValueExBinary(lngHKey, strValueName, 0&, _ lngValueType, VarPtr(abytValueData(0)), lngDataSize) End If If mcregErrorNone = lngRetVal Then varValue = abytValueData Else varValue = Empty End If Case Else 'No other data types supported lngRetVal = -1 End Select End If RegCloseKey (lngHKey) End If 'Return varValue RegistryGetKeyValue = varValue PROC_EXIT: Exit Function PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryGetKeyValue" Resume PROC_EXIT End Function Public Sub RegistrySetKeyValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String, _ varData As Variant, _ eDataType As EnumRegistryValueType) Dim lngRetVal As Long Dim lngHKey As Long Dim strData As String Dim lngData As Long Dim abytData() As Byte On Error GoTo PROC_ERR ' Open the specified key, If it does not exist then create it lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _ mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&) ' Determine the data type of the key Select Case eDataType Case rrkRegSZ strData = varData & vbNullChar lngRetVal = RegSetValueExString(lngHKey, strValueName, 0&, eDataType, _ strData, Len(strData)) Case rrkRegDWord lngData = varData lngRetVal = RegSetValueExLong(lngHKey, strValueName, 0&, eDataType, _ lngData, Len(lngData)) ' Binary type Case rrkregbinary abytData = varData lngRetVal = RegSetValueExBinary(lngHKey, strValueName, 0&, eDataType, _ VarPtr(abytData(0)), UBound(abytData) + 1) End Select RegCloseKey (lngHKey) PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistrySetKeyValue" Resume PROC_EXIT End Sub ' مثال لإنشاء مفتاح رئيس تحت الجذر [CODE]RegistryCreateNewKey HKeyUsers, "New Floder\Sub Floder" ' مثال على إسناد قيمة لمفتاح فرعي ' إذا لم يجد المفتاح الفرعي فإنه ينشئه RegistrySetKeyValue HKeyUsers, "New Floder\Sub Floder", "اسم كائن", True, rrkRegSZ MsgBox RegistryGetKeyValue(HKeyUsers, "New Floder\Sub Floder", "اسم كائن") ' حذف قيمة مسندة لمفتاح فرعي RegistryDeleteValue HKeyUsers, "New Floder\Sub Floder", "اسم كائن" ' مثال لحذف مفتاح رئيس تحت الجذر RegistryDeleteKey HKeyUsers, "مجلد جديد" علماً أنني نقلته من أحد المواقع . وللجميع التحية