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

استاذ عبد العزيز الكود موجود في حدث الورقة علي العموم هذا هو الكود ان كان هو طلب السائل ............. توضيح الكود للاستاذ " ياسر خليل " Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("A1:A100")) Is Nothing Then Cancel = True Target.Font.Name = "Marlett" If Target = vbNullString Then Target = "a" Else Target = vbNullString End If End If End Sub

فكرة رائعة بارك الله فيك وهنا تطوير للفكرة وبالمرفق مزيد من الشرح الماكرو تم وضعه في حدث الصفحة change تنبيهات 2.rar

الاخ العزيز جعفر مجهود رائع فعلا لقد قمت بتثبيته لاهمية مجهودك

بسم الله الرحمن الرحيم اقدم لكم اليوم هديه برنامج صلاحيات المستخدمين ويمتاز هذا البرنامج بالتالى : ولكن قبل ان نبين مميزات البرنامج لابد من حفظ الحقوق فلقد بداء هذا البرنامج الاستاذ الفاضل / عبد الله المجرب واتم العمل من استكمال للاكواد وعمل التعديلات المطلوبه وتامينه فهو الاستاذ / عباد ابو نصار وتم الاستعانه بكود من مشاركات الاستاذ / عبد الله باقشير فى التنقل لاى صفحه فى المستند والان وقد اكتمل العمل ولكنه قابل للتطوير من الاستاذة الافاضل طبعا وهذا ما نطمح اليه مميزات البرنامج 1- انه سهل الاستخدام فانه يعمل بمجرد ان ترفق له اى عدد من الصفحات تصل الى 254 صفحه وقابله للزيادة عند تعديل جزء صغير فى الكود 2- اعطاء الصلاحيات عن طريق نموذج سهل الاستخدام وبيسر فهو يعطى ثلاث انواع من الصلاحيات (مشاهدة وتعديل اى صلاحيات كامله - مشاهدة فقط - اى للاطلاع - مخفى اى اخفاء هذة الصفحه عن المستخدم 3- يتم تسجيل اسم المستخدم والتاريخ والوقت لكل حركه دخول 4- صفحه mydate هى الصفحه الهامه فى الملف ففيها يتم تسجيل كل الصلاحيات واسماء المستخدمين وكلمات السر الخاصه بهم 5- مرونه عاليه فى الغاء واضافه الصفحات وتغير اسماءها دون التاثير على البرنامج فمبجرد اغلاق البرنامج والدخول عليه يتم تحديث بياناته تلقائيا 6- غير قابل الاختراق عن طريق رفع الامان فى الماكرو 7- الصفحات الرئيسيه فيه هى صفحه mydate وورقه رقم 1 وما دون ذلك قابل للحذف او التغيير المسمى او الاضافه ويتعامل كما ذكرت سابقا حتى 254 صفحه بعد اذن الاستاذة الافاضل / مصممي البرنامج قمت بوضعه فى هذة المشاركه بهدف ان تعم الفائدة من علمكم الغزير وكذلك اعتبارة برنامج قابل للتطوير وذلك لسهوله فكرته ومرونته فى التغيير حسب متطلبات كل شخص لان المشكله التى كانت تواجه اى مستخدم عادى عندما يجد ملف عن نفس هذا الموضوع هو كيفيه تطويعه الى الطريقه التى يعمل بها اما فى هذا الملف فما عليه سوى نقل الصفحات التى يرغبها من ملفاته وسوف يعمل عليها البرنامج بشكل تلقائى وسهل للدخول على البرنامج بصلاحيات كامله : اسم المستخدم : الدعم الفنى كلمه السر 111 ومن داخل صفحه mydate ستجد باقى الاسماء ومعها كلمات السر الخاصه بها عندما تكتب كلمه السر الخاصه بالدعم الفنى ستجد ازار الصلاحيات وكلمه السر تم تفعيلها ومن ثم تسطيع التجول فى البرنامج ومن داخله ايضا تستطيع تغيير كلمه السر صلاحيات المستخدم_.rar

السلام عليكم إخوتي خبراء إكسيل الكرام: طرح علي اﻷخ westexcel سؤالا ظنا منه أنني مهندس في مجال البرمجة وبما أنه في مجال بحركم الواسع الذي تخوضون غماره فإنني أحيل سؤاله عليكم رغبة بمساعدته. فالدال على الخير كفاعله أقدم لكم السؤال الذي طرحه..ولكنني أطلب منه فضلا لا أمرا تعريب اسمه الكريم ...ومتابعة هذا الموضوع ليقوم بإدراج الملف والبيانات التي تساعدكم ﻹيصاله إلى شط اﻷمان في هذه المسألة...وكلي رجاء أن تقدموا ما تستطيعوه ...تقبلوا تحياتي العطرة.. ما هي طريقة برمجة الحروف مع الآرقام يعني ا ب ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن هـ و ي 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 1110 9 8 7 6 5 4 3 2 1 يعني كل حرف يقابله رقم حسب الترتيب من أ -ي 28-1 وعندما اكتب عبارة في خانة الكتابة تظهر لي نتيجة الحروف يعني مثلا كتبت " الصحة" تظهر النتيجة بعد الجمع 26+5+14+23+1 = 69 يعني انا الذي اريده تظهر لي النتيجة مباشرة 69

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

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

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

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

السلام عليكم استاذ محمد سؤال جميل ..... وموضوع يستحق المتابعة لنتعلم كيف الطريق ....... اساهم معك ببكود .... الاستاذ هشام شلبي ..... عثرت عليها سابقاً هو مختلفة لكن ممكن تستعين به و يساعدك بفكرة ما الجمع في خلية.rar الجمع في خلية.rar

السّلام عليكم و رحمة الله و بركاته أخي الكريم abo jana14 بانتظار ملف أستاذنا الغالي KHMB .. يمكن لك أخذ فكرة ولو بسيطة عن الموضوع في هذا الرابط : http://www.officena.net/ib/topic/63809-ممكن-كود-عمل-صلاحية-للفورم-لمدة-محدودة-استخدم-اكسل-2010/ فائق احتراماتي

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

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

جرب هذا الملف انه يعمل بشكل آلي بمجرد ما تغير شيئاَ في الجدول الثاني لائحة جاهزة اسعار الجملة 2015 salim.zip

السلام عليكم ورحمة الله أخي الكريم، أعتقد أنه يجب وضع الكود المعني في موديول مستقل Standard Module وليس مثل ما فعلت بوضعه في All Open Workbooks ثم ربطه بـ زر Button في أي شيت من الشيتات... والله أعلى وأعلم أخوك بن علية

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

السلام عليكم الفكرة جميله وتنفع فى جدولة الأعمال او اعياد الميلاد لكن فيها خطأ برمجى صغير فى السطر expd = Worksheets("Notifications").Range("A2") المفروض انه يقرا من الخلية A1 فى الشيت Main expd = Worksheets("Main").Range("A1") وكمان تبقى افضل لو حدد ادنى للتاريخ انه ما يكونش اقل من تاريخ اليوم لانى لاحظت انه جايب لى تنبيهات من سنة فاتت بتغيير السطر التالى If (.Cells(irow, 7) - MyDate) <= expd Then الى If (.Cells(irow, 7) - MyDate) <= expd And (.Cells(irow, 7) - MyDate) > -1 Then تنبيهات 1.rar

السلام عليكم ضع في زر امر اخفاء Application.SetHiddenAttribute acTable, "YourTable", True وفي زر اظهار Application.SetHiddenAttribute acTable, "YourTable", False DB1.rar

السلام عليكم ورحمة الله تم تعديل الملف في شيت "واجهه" وتعديل معادلات أيام كل شهر (معادلات تلقائية تحدد أيام الشهر بمجرد كتابة رقم الشهر في الخلية المناسبة بالأعلى)... أرجو أن يكون المطلوب بن علية خط سير شهرى4.rar

استاذي الفاضل / عباد المحترم السلام عليكم ورحمه الله وبركاته اسعدني مرورك واتمنى المتابعه معنا هنا فلا تحرمنا تواجدك معنا والاستفادة من علمكم الوفير وهذة نسخ من البرنامج باصدارات 2003 و 2007 صلاحيات المستخدم 2003-_.rar صلاحيات المستخدم_- 2007.rar

جزاك الله خير اخي himass اكيد بيستفيد منه الكثير حبذا ترفق نسختين نسخه 2003 واخر 2007 تقبل مروري

السلام عليكم ورحمة الله وبركاته استكمالا لسلسلة شرح الجمل الشرطية سنستحدث سلسلة اخرى تتعلق بكيفية استخدام الخلايا في ال vba وكان من المفروض البدء بها قبل شرح الجمل الشرطية لكونها تعتمد عليها في بعض الجوانب وسيتم تناول ثلاثة مواضيع بالتناوب وهي : 1. استخدام جمل ال range 2. استخدام جمل ال cells 3. استخدام جمل ال offset وسنبدأ بالموضوع الاول ...حيث هناك مرفق تم فيه شرح الكيفية في الاستخدام الموضوع باجتهاد شخصي وقد يحتمل الصواب والخطأ وقد يحتمل النسيان فان كنت قد أصبت فالحمد لله وانت كنت قد اخطأت فذلك يعلمني وان كنت قد نسيت فجل من لا ينسى او ان اكون قد اغفلت بعض الجوانب التي لم اضعها في الحسبان وهذه دعوة مفتوحة للجميع بالمشاركة في هذا الموضوع حتى يكون موضوع هادف وكامل ومفيد ان شاء الله اخوكم عماد الحسامي hosami range.rar

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

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

موجودة وانت الصادق ، ولكن استعمل acViewPreview بدل عن acPreview جعفر

اعتقد ان هذا المطلوب Dates Conditional Formating salim.zip

السلام عليكم ورحمة الله بأي طريقة تريد الفترة التجريبية 1- بعدد مرات فتح الملف 2- او بتاريخ معين يوم اسبوع شهر .... إلخ. ابو الحسن والحسين

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

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

وعليكم السلام أخي حسين استخدم هذا الكود في الحدث "بعد التحديث": Private Sub cmb_Items_AfterUpdate() 'method ONE: 'to use this moethod, you have to select: 'Tools > References > Microsoft Excel xx.x Object Library ' Dim objXL As New Excel.Application ' objXL.Application.Speech.Speak Me.cmb_Items ' Set objXL = Nothing 'methos TWO: 'SAPI commands: https://msdn.microsoft.com/en-us/library/ms723627(v=vs.85) Dim objSpeech As Object Dim intPitch As Integer Set objSpeech = CreateObject("SAPI.SpVoice") intPitch = 2 objSpeech.Speak "<pitch middle = '" & intPitch & "'/>" & Me.cmb_Items Set objSpeech = Nothing End Sub جعفر 223.textTOspeech.mdb.zip

بالفعل هذا ماقصدته اخي ابو محمد

شكرا على الكود الجميل فقط عندي اقتراح أن يتم تفريغ الفورم من الداكرة ال memory عوض اخفائه .. ايضا لا داعي لتكرار المصفوفة داخل ال UnloadUF Option Explicit Dim X As Integer Dim iuserform As Variant Sub showUF() ' by mokhtatr 19/9/2015 iuserform = Array(UserForm1, UserForm2, UserForm3, UserForm4) For X = LBound(iuserform) To UBound(iuserform) Application.OnTime Now + TimeValue("00:00:01"), "UnloadUF" iuserform(X).Show Next X End Sub Sub UnloadUF() Unload iuserform(X) Application.Wait Now + TimeValue("00:00:01") End Sub كدالك لا ينبغي نسيان أن المستخدم يمكن له أن يغلق الفورم بالضغط على الزر x و لهدا يجب اضافة كود داخل اليوزرفورم موديول كالتالي Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Cancel = Not CloseMode End Sub بالمناسبة يمكن كتابة كود لا يستوجب استخدام عدد معين من اليوزرفورم و انما يستخدم فقط ال Standard MsgBox الكود أكثر تعقيدا لكنه ممكن

اخي ياسر اعلم بأنك تريد الايضاح للاخوة فأنت من أساتذة هذا المنتدى وارجوا ان يفي بذلك الشرح المرفق ادناة الفكرة تقوم على انه في حالة وضع بيانات عملاء مثلا او موردين ......الخ ووضع تاريخ زيارة او استحقاق في تاريخ معين في شيت "Machines_Card" وقمنا بتحديد المدة المدة الواجب التنبية عليه والموجودة في الخلية "A1" في شيت "Main" فسيتم حساب عدد التنبيهات وفقا لععد الحالات المطابقة واظهارها في منطقة الجرس وبالضغط على ايقونة الجرس سيتم عمل لنسخ لتلك الحالات لشيت "Notifications" حتى يسهل طباعتها او متابعتها او ايا" كان المراد منها ارجوا ان اكون وفقت وفقنا الله واياكم

دائما أخي الحبيب والرائع ياسر خدوم بارك اللهفيك وفي أولادك جربت الكود وشغال معي تمام ما فيه اي مشكلة

ارفق ملف كمثال للتوضيح

السلام عليكم الملف شغال بس انت عامله مختفى "hidden" الغى الاخفاء واعمل له حفظ وهو يشتغل تمام لما تفتحه تانى

السّلام عليكم و رحمة الله و بركاته جزاك الله خيرًا و زادها بميزان حسناتك .. كل حرف تكتبه بألف حسنة إن شاء الله .. مجهود كبير تقوم به ..فلترة و تجميع و حفظ .. بارك الله فيك يا غالي يا أبا يوسف وافر احتراماتي

ممتاز ورائع حقاً أخي الغالي جعفر الآن .. بدأ الفورم يعمل .. عند الشروع في العمل والضغط على زر Start تظهر الضور المقطعة بشكل طبيعي ولكن عند بداية سحب الصور تظهر الصور بخلفية بيضاء وتختفي الصورة ...

مشكورين على الردود أستادي الفاضل ياسر بدل ال olepro32.ddl ب OleAut32.dll لتصبح كالتالي : Private Declare Function OleCreatePictureIndirect Lib "OleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

وعليكم السلام أخي حسين تفضل الرابط http://www.officena.net/ib/topic/59612-سؤال-عن-اخفاء-الجداول/?do=findComment&comment=382261 جعفر

أبي الحبيب الغالي أبو يوسف بارك الله فيك على مجهودك الرائع .. وأتمنى أن يقوم أحد المحترفين في مجال تحويل المادة العلمية الموجودة إلى كتاب إلكتروني يجمع كل ما ييسر الله به ليكون مرجعاً لكل من أراد أن يبدأ مشوار التعلم ويكون نبراساً نهتدي به في هذا العلم تقبل وافر تقديري واحترامي

الاخ العزيز ساشرح لك طريقة وان شاء الله تفيدك قم بعمل ملف جديد وضع فيه ملفك ثم قم بفتح درايف الـ C ثم اختر Programfiles ثم قم بفتح مجلد برنامج الـ WinRAR ثم انسخ منه الملف UnRAR زوضعه داخل المجلد الذى قمت بانشائه من قبل ووضعت فيه ملفك ثم قم بفتح المفكرة وانسخ بها الكود التالى ثم احفظه بداخل المجلد باسم Passwardcrcker.Bat ثم قم بالضغط على هذا الملف الذى قمت بانشاءه وقم بنسخ مسار ملف من داخل المجلد الذى انشاته ثم الصقه داخل الشاشة السوداء التى ستظهر معك بعد الضغط على الملف الذى به الكود واضغط انتر وانتظر حتى تظهر لك كلمة السر الخاصة بملفك مرفق الكود WinRAR Password _er.rar

اخي العزيز التغيير في نموذج تسجيل الطلاب في الدورات تم تعديل حقل متاح Dawrat7.rar

السلام عليكم لقد انتهيت من تصميم الفورم و الكود .. كتبت الكود و جربته على أوفيس 2007 ويندوز XP طبعا ينبغي تعديل ال API Declarations لكي يعمل الكود على الويندوز 64 بت ارجو أن يعجبكم العمل لقطة من اشاشة : ملف للتحميل : https://app.box.com/s/pn0ogngk3swhfbxbugk8f87ookrqb18b الكود: 1- كود في موديول الفورم: PaintingPuzzleGame Option Explicit Private Type POINTAPI X As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function FindWindow Lib "User32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function InvalidateRect Lib "User32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const SND_ASYNC As Long = &H1 Private Const SND_FILENAME As Long = &H20000 Private Const SND_LOOP As Long = &H8 Private Const SND_PURGE = &H40 'Module level variables Private oCol As Collection Private oPic As Object Private bScore As Boolean Private bExit As Boolean Private bAbort As Boolean Private InitialFormLeft As Single Private InitialFormTop As Single Private lFrmHwnd As Long Private lCounter As Long Private lTotalImageParts As Long Private lColumns As Long Private lRows As Long Private sLevel As String Private sUserName As String Private vFileName As Variant Private Sub UserForm_Initialize() sUserName = InputBox("Please, enter your name", "Player Name") If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End If StrPtr(sUserName) = 0 Then End End Sub Private Sub UserForm_Activate() StartUpPosition = 2 InitialFormLeft = Me.Left InitialFormTop = Me.Top Set oPic = frameSourcePic.Picture lFrmHwnd = FindWindow(vbNullString, Me.Caption) frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow With Me.ComboLevel .AddItem "Easy " & " (3x6 Parts)" .AddItem "low " & " (3x8 Parts)" .AddItem "Medium " & "(4x10 Parts)" .AddItem "High " & "(6x13 Parts)" .ListIndex = 0 End With lblTimer.Caption = "" CBtnAbort.Enabled = False Call EnableControls(True) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then Cancel = 1 Exit Sub End If bExit = True End Sub '*************************************************************************************************** 'Event handlers of form's controls Private Sub ComboLevel_Change() Select Case True Case UCase(ComboLevel.Value) Like "EASY*" lRows = 3 lColumns = 6 Case UCase(ComboLevel.Value) Like "LOW*" lRows = 3 lColumns = 8 Case UCase(ComboLevel.Value) Like "MEDIUM*" lRows = 4 lColumns = 10 Case UCase(ComboLevel.Value) Like "HIGH*" lRows = 6 lColumns = 13 End Select sLevel = UCase(ComboLevel.Value) End Sub Private Sub CBtnAbort_Click() Call EnableControls(False) bAbort = True End Sub Private Sub CBtnClose_Click() Unload Me End Sub Private Sub CBtnNewPic_Click() On Error GoTo errHandler vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _ Title:="Select Picture") If vFileName <> False Then frameSourcePic.Picture = LoadPicture(vFileName) Call DeletePreviousImages End If Exit Sub errHandler: MsgBox Err.Description End Sub Private Sub CBtnStart_Click() Dim oImagePartCls As oImagePartCls Dim oTextBox As msforms.TextBox Dim tRect As RECT Dim tPt1 As POINTAPI, tPt2 As POINTAPI Dim BasePicframeHwnd As Long Dim lImgPartWidth As Long, lImgPartHeight As Long Dim lImgPartLeft As Long, lImgPartTop As Long Dim lColumn As Long, lRow As Long Dim lControlCounter As Long bScore = False bAbort = False Call EnableControls(False) BasePicframeHwnd = frameSourcePic.[_GethWnd] GetWindowRect BasePicframeHwnd, tRect tPt1.X = tRect.Left tPt1.y = tRect.Top tPt2.X = tRect.Right tPt2.y = tRect.Bottom If IsFormClipped(tPt1, tPt2) Then Me.Move InitialFormLeft, InitialFormTop GetWindowRect BasePicframeHwnd, tRect DoEvents End If Call DeletePreviousImages 'add the image parts controls Set oCol = New Collection For lColumn = 1 To lRows For lRow = 1 To lColumns lControlCounter = lControlCounter + 1 Set oImagePartCls = New oImagePartCls Set oImagePartCls.GetForm = Me Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter) With oImagePartCls.PicturePart .PictureSizeMode = fmPictureSizeModeStretch .BorderStyle = fmBorderStyleSingle .BorderColor = vbYellow .MousePointer = fmMousePointerSizeAll .Width = frameSourcePic.Width / lRows .Height = frameSourcePic.Height / lColumns .Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows)) .Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns)) .ZOrder 0 .ControlTipText = "Drag the Picture down to its corresponding empty frame below" End With oCol.Add oImagePartCls Next Next 'add the textbox holder controls lControlCounter = 0 For lRow = 1 To lColumns For lColumn = 1 To lRows lControlCounter = lControlCounter + 1 Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter) With oTextBox .Enabled = False .BackStyle = fmBackStyleTransparent .BorderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectEtched .Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows .Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns .Width = oImagePartCls.PicturePart.Width .Height = oImagePartCls.PicturePart.Height .ZOrder 1 End With Next Next 'randomly shuffle the image part controls lTotalImageParts = lColumns * lRows Me.Tag = lTotalImageParts ReDim iArray(1 To lTotalImageParts) As Integer ' Call ShufflePictureParts(lTotalImageParts, iArray) 'set the Pic property of each image part lControlCounter = 0 For lColumn = 1 To lColumns For lRow = 1 To lRows With tRect lImgPartWidth = (.Right - .Left) / lRows lImgPartHeight = (.Bottom - .Top) / lColumns lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth) lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight) End With lControlCounter = lControlCounter + 1 Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter)) InvalidateRect lFrmHwnd, 0, 0 Next Next frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow Call UpdateTimerLabel End Sub '************************************************************************************************* ' Private Supporting routines Private Sub UpdateTimerLabel() Dim ss As Long Dim mm As Long Dim hh As Long Dim sglTimer As Single Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV" sglTimer = Timer Do ss = Int(Timer - sglTimer) If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer If mm = 60 Then hh = hh + 1: mm = 0: sglTimer = Timer lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" DoEvents Loop Until bExit Or bScore Or bAbort If bScore Then PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC If MsgBox("Congratulations " & sUserName & " !!" & vbCrLf & vbCrLf & _ "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _ "Do you want to save this score to your scores history ?", vbQuestion + vbYesNo) = vbYes Then Call SaveTheScore(hh, mm, ss) End If PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE End If lblTimer.Caption = "" Call EnableControls(True) Call DeletePreviousImages Set frameSourcePic.Picture = oPic End Sub Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long) Dim bProtection As Boolean bProtection = ActiveSheet.ProtectContents If bProtection Then ActiveSheet.Unprotect End If With Cells(Cells.Rows.Count, 1).End(xlUp) .Offset(1, 0) = sUserName .Offset(1, 1) = Now .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName) .Offset(1, 3) = sLevel .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" End With If bProtection Then ActiveSheet.Protect End If ThisWorkbook.Save End Sub Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal X, ByVal y, DestCtrl As Image) Dim hdc As Long Dim hDCMemory As Long Dim hBmp As Long Dim OldBMP As Long Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture hdc = GetDC(0) hDCMemory = CreateCompatibleDC(hdc) hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight) OldBMP = SelectObject(hDCMemory, hBmp) Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, X, y, SRCCOPY) With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hBmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic Set DestCtrl.Picture = IPic ReleaseDC 0, hdc DeleteObject OldBMP DeleteDC hDCMemory End Sub Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer) Dim i As Integer, lRandomNumber As Integer, temp As Integer For i = 1 To NumOfPics Arr(i) = i Next i Randomize Timer For i = 1 To NumOfPics lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr)) temp = Arr(i) Arr(i) = Arr(lRandomNumber) Arr(lRandomNumber) = temp Next i End Sub Private Sub DeletePreviousImages() Dim i As Long Dim oCtl As Control On Error Resume Next If Not oCol Is Nothing Then For i = 1 To oCol.Count Controls.Remove Controls("Image" & i).Name Next For Each oCtl In Me.Controls If TypeName(oCtl) = "TextBox" Then Controls.Remove oCtl.Name End If If TypeName(oCtl) = "Image" Then Controls.Remove oCtl.Name End If Next End If End Sub Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean IsFormClipped = _ tLeftTop.X <= 1 Or tLeftTop.y <= 1 Or tRightBottom.X >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _ tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1 End Function Private Sub EnableControls(ByVal Bool As Boolean) CBtnAbort.Enabled = Not Bool CBtnNewPic.Enabled = Bool CBtnStart.Enabled = Bool ComboLevel.Enabled = Bool End Sub '************************************************************************************************************* ' Public Methods Public Sub MsgbBeep() MessageBeep &H40& End Sub Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As msforms.TextBox) Dim i As Long Dim t As Single For i = 0 To 1 Img.BorderStyle = fmBorderStyleSingle Img.BorderColor = vbRed t = Timer Do DoEvents Loop Until Timer - t >= 0.2 Img.BorderStyle = fmBorderStyleNone Next End Sub Public Sub CheckIfSuccess() Dim oCtrl As Control Dim lCounter As Long For Each oCtrl In Me.Controls If TypeName(oCtrl) = "Image" Then If InStr(1, oCtrl.Tag, "Success") Then lCounter = lCounter + 1 If lCounter = lTotalImageParts Then bScore = True End If End If End If Next End Sub 2- الكود في الكلاس موديول : oImagePartCls Option Explicit Public WithEvents PicturePart As msforms.Image Private initialY As Single, initialX As Single Private oUForm As Object Public Property Set GetForm(ByVal vNewValue As Object) Set oUForm = vNewValue End Property Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) initialX = X: initialY = y PicturePart.ZOrder 0 End Sub Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) Dim oCtrl As Control Static oPrevCtrl As Control If Button = 1 Then With PicturePart .Move .Left + (X - initialX), .Top + (y - initialY) For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then If Not oPrevCtrl Is Nothing Then oPrevCtrl.Enabled = False oPrevCtrl.BackStyle = fmBackStyleTransparent oPrevCtrl.SpecialEffect = fmSpecialEffectEtched End If If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then oCtrl.Enabled = True oCtrl.BackStyle = fmBackStyleOpaque oCtrl.SpecialEffect = 6 oCtrl.BackColor = vbWhite Set oPrevCtrl = oCtrl Exit For End If End If Next End With End If End Sub Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) Dim oCtrl As Control For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then With PicturePart If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then .Move oCtrl.Left, oCtrl.Top PicturePart.BorderStyle = fmBorderStyleNone Call oUForm.FlashImagePart(PicturePart, oCtrl) If InStr(1, PicturePart.Tag, oCtrl.Name) Then PicturePart.Tag = PicturePart.Tag & "Success" Else If Right(PicturePart.Tag, 7) = "Success" Then PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7) End If End If Call oUForm.MsgbBeep Call oUForm.CheckIfSuccess Exit For End If End With End If Next End Sub

السلام عليكم اخي ولد الحجاز بعد اذن الاخوة هل تقصد كما في المرفق xx.rar

مرسل مثال لكشف الاسماء المراد ترحيلهم الى الاستبانة وشكرا لكم على المتابعة الكشف.rar

السلام عليكم ورحمة الله وبركاته إخواني الكرام ..أحبابي في الله **************** أقدم لكم درس جديد ، لعله أن يكون مفيد ، ويعجب الأخ الغالي عادل أبو زيد ، والأخ الحبيب أبو عيد ، واللي ميعجبوش الدرس يبعد بعيد .. درس اليوم عن استخدام دوال الإكسيل أو معظم الدوال الموجودة في الإكسيل في محرر الأكواد .. أترككم مع الفيديو .. ولا تنسوا لايكات على اليوتيوب ولايكات على الموضوع ولايكات للمنتدى ولايكات للأعضاء (الليلة ليلة اللايكات) ولا تنسوا قبل كل ذلك والأهم من ذلك ..دعواتكم بظهر الغيب إليكم رابط الفيديو أرجو أن ينال الموضوع إعجابكم وتستفيدوا منه .. أخوكم أبو البراء WorksheetFunction VBA.rar

بعد كده هنضرب الودع وهنقرا الكف ههههههههههههه شرفنى واسعدنى مرورك اخى الحبيب ابوايمان تحياتى

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

جزاك الله كل خير للاستجابة السريعة واقدرها لك تم ارفاق ملف Desktop.rar