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

استاذ عبد العزيز الكود موجود في حدث الورقة علي العموم هذا هو الكود ان كان هو طلب السائل ............. توضيح الكود للاستاذ " ياسر خليل " 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 تقبل مروري

الاخوة الزملاء لعبة تركيب صورة للاطفال على اكسل 2010 لعبة تساعد الطفل على التعرف على الصورة ثم اعادة تركيبها وهى فكرة الاخ عبد الله باقشير تحريك اجزاء صورة على الرابط http://www.officena.net/ib/index.php?showtopic=41620 لعبة الصورة المتحركة.rar

اليوم اقدم لكم أضخم كتاب عربي لتعلم برنامج EXCEL يحتوي على شرح مفصل لصيغ والدوال وكذالك مرفق مع الكتاب تطبيقات نموذجية . غلاف الكتاب المحتويات 1.بداية الكتاب معلومات اساسية عن برنامج إكسل 2007 2. استخدام الدالات في الصيغ 3. شرح كافة المعادلات في والتطبيق في إكسل 4. شرح صيغ الصفيف وأمثلتها المستحيلة في إكسل 5. شرح جداول Pivot والمراجع الدائرية المقصودة والمخططات والرسوم البيانية والتنسيق الشرطي والادوات والتنقيح 6.في النهاية الغير متوقعة شرح لغة VBA وطريقة كتابة الصيغ فيها لتحميل الكتاب اضغط هنا حجم الكتاب: 39.7 MB رابط اخر على 4shared أرجو الدعاء لي ولصاحب الكتاب وناشره جزاكم الله خيرا

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

المرفق في الموضوع السابق هو اختصار لملف وليس الملف كامل اخي عبدالعزيز

هذا مثال للعملية المطلوبة http://arabsh.com/files/0b374d4e64f0/n2-xlsx.html بالنسبة لملف الأخ الفاضل محمد الحازمي لم تنجح حتى ان الدالة التي في الملف قديمة ولا توجد في اكسل 2013 لكن ليست هي المطلوبة وقد ارفقت لكم ملف لمعرفة المطلوب بالتحديد شكرا لكم مقدما على ما تقدمونه

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

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

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

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

وعليكم السلام أخي حسين استخدم هذا الكود في الحدث "بعد التحديث": 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

اخى عبد العزيز جرب ايضا الكود الاتى Sub hima_trs2() Dim LR As Long Dim LR1 As Long Dim WS As Worksheet Dim WS1 As Worksheet Set WS1 = Worksheets("ترحيل الفاتورة") Set WS = Worksheets("فاتورة بيع") If WorksheetFunction.CountIf(WS1.[C3:C10000], WS.[f6]) <> 0 Then MsgBox "This invoice already exist, No shift will done": Exit Sub LR1 = WS.Range("a11").End(xlDown).Row With WS.Range("a11:h" & Cells(Rows.Count, "a").End(xlUp).Row) If .Row = 11 Then LR = WS1.Cells(Rows.Count, "B").End(xlUp).Row + 1 WS1.Cells(LR, "B").Resize(.Rows.Count, 1).Value = WS.[f7] WS1.Cells(LR, "C").Resize(.Rows.Count, 1).Value = WS.[f6] WS1.Cells(LR, "D").Resize(.Rows.Count, 1).Value = WS.[c6] WS1.Cells(LR, "e").Resize(.Rows.Count, 1).Value = WS.[c7] WS1.Cells(LR, "f").Resize(.Rows.Count, 1).Value = WS.Range("h11:H" & LR1).Value WS1.Cells(LR, "g").Resize(.Rows.Count, 1).Value = WS.Range("g11:g" & LR1).Value WS1.Cells(LR, "h").Resize(.Rows.Count, 1).Value = WS.Range("f11:f" & LR1).Value WS1.Cells(LR, "i").Resize(.Rows.Count, 1).Value = WS.Range("e11:e" & LR1).Value WS1.Cells(LR, "j").Resize(.Rows.Count, 1).Value = WS.Range("d11:d" & LR1).Value WS1.Cells(LR, "k").Resize(.Rows.Count, 1).Value = WS.Range("c11:c" & LR1).Value WS1.Cells(LR, "l").Resize(.Rows.Count, 1).Value = WS.Range("b11:b" & LR1).Value End If End With End Sub تقبل تحياتى

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

انا مش فاهم ارقم 45جبته منين اخى عبد العزيز هل تقصد هكذا Sub trs_invoice() Application.ScreenUpdating = False Dim LR As Long, LR1 As Long Dim WS As Worksheet Dim WS1 As Worksheet Set WS = Worksheets("فاتورة بيع") Set WS1 = Worksheets("ترحيل الفاتورة") LR1 = WS1.Range("c55555").End(xlUp).Row + 1 Dim FR For R = 3 To LR1 If WS1.Cells(R, 3) = WS.Range("f6") Then MsgBox "This invoice already exist, No shift will done": Exit Sub Next For FR = 11 To 27 If WS.Cells(FR, 2) = "" Then GoTo 7 WS1.Cells(LR1, 2) = WS.Range("F7").Value WS1.Cells(LR1, 3) = WS.Range("F6").Value WS1.Cells(LR1, 4) = WS.Range("C6").Value WS1.Cells(LR1, 5) = WS.Range("C7").Value WS.Range("B" & FR & ":H" & FR).Copy WS.Range("h" & FR & ":H" & FR).Copy WS1.Range("F" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("g" & FR & ":g" & FR).Copy WS1.Range("g" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("f" & FR & ":f" & FR).Copy WS1.Range("h" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("e" & FR & ":e" & FR).Copy WS1.Range("i" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("d" & FR & ":d" & FR).Copy WS1.Range("j" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("c" & FR & ":c" & FR).Copy WS1.Range("k" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS.Range("b" & FR & ":b" & FR).Copy WS1.Range("l" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False LR1 = LR1 + 1 7 Next FR Application.CutCopyMode = False WS.Select Application.ScreenUpdating = True End Sub تقبل تحياتى

شكرا على الكود الجميل فقط عندي اقتراح أن يتم تفريغ الفورم من الداكرة ال 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 الكود أكثر تعقيدا لكنه ممكن

بجرب مره اخري وبشوف ممكن تكون المشكله عندي اخي ابو محمد وشاكر لاهتمامك اخي العزيز اخي ياسر جربت اغيره وما نفع ممكن تقولي الكيفيه وانا بغيره ان شاء الله

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

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

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

أخي الحبيب جعفر يبدو أنني سأكون مصدر إزعاج لك .. قمت بالتعديل على API Declarations لكي يعمل الكود على الويندوز 64 بت وعند التنفيذ ظهرت لي رسالة File not found : olepro32.dll أعمل على ويندوز 10 64 بت ...

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

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

شكرا لك أخي سليم على هذا الحل وهذا حل آخر بالأكواد لا يلزم منه الحفاظ على ترتيب الأسماء طريقة الاستخدام 1/ ادخل على شيت بطاقة موظف 2/ في الخلية B1 اكتب بعض الأحرف للاسم المراد البحث عنه (أو الاسم كله كما تريد) ثم اضغط زر البحث مثال : إذا كتبت (علي) يسظهر لك كل الأسماء التي فليها (علي أو عليان أو علياء أو عليوي .....) 3/ في قائمة الأسماء الموجودة في العمود D أنقر نقرا مزدوجا (مرتين) على أي أسم من الأسماء الموجودة ولاحظ النتيجة تحياتي البحث في شيت داتا عن اسم الموظف1.rar

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

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

مع ملاحظه انه بعد دخولك للبرنامج سيتمكن المستخدم من تغيير كلمه السر الخاصه به من خلال زر تغيير كلمه السر الموجود بالصفحه الاولى وسيجد اسمه ومطلوب كلمه السر القديمه والجديدة ويتم التغيير فى صفحه mydate

الاخ الفاضل / amfouad555 تحديد الصلاحيات لا يتم من صفحه mydate ولكن من خلال نموذج الصلاحيات الذى يتم الوصول اليه من شاشه الدخول عندما تدخل باسم الدعم الفنى وبعد كتابه كلمه السر وقبل دخولك للبرنامج اضغط على زر تحديد الصلاحيات فيفتح لك نموذج تختار من اعلى القائمه اسم المستخدم فتظهر لك صلاحياته بالاسفل على كل صفحه ويوجد فى الاسفل اربع اختيارات تساعدك فى ملىء النموذج باحد الصلاحيات لجميع الصفحات ثم بعد ذلك تختار من الكومبوبوكس امام اى صفحه تريد تغيير صلاحيتها ومن ثم تقوم بالحفظ فيتم الحفظ مباشرة فى صفحه mydate واكرر ان صفحه mydate لا يتم التعامل معها بشكل مباشر الا فى شىء واحد فقط اذا اردت تغيير اسم مستخدم موجود فعلا وما دون ذلك يتم من خلال النماذج سواء بتغير الصلاحيات او اضافه مستخدمين او تغيير كلمه السر و التعامل من خلال النماذج اسهل مما تتخيل ولكن فقط ستتمكن من هذة النماذج مع المستخدم الدعم الفنى وكتابه كلمه السر الصحيحه له وهى 111 واتمنى اكون قد اوضحت الفكرة واى استفاسر ان شاء الله حاضرين

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

من أعمال الأستاذ خبور Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim CC As Integer, C As Integer Dim sR As String Dim MyRng As Range Set MyRng = Range("n8:Aw78") If Not Intersect(Target, MyRng.Cells) Is Nothing Then Application.EnableEvents = False CC = MyRng.Column - 1 C = Target.Column - CC sR = MyRng.Columns(C).Address If Application.CountIf(Range(sR), Target.Value) > 1 Then If MsgBox(" this value was enter" & vbLf & vbLf & "Do you want to continue? ", 16 + vbYesNo + 524288 + 1048576, "Note") = vbNo Then Target.ClearContents End If End If Kh_ColorIndex Range(sR) Application.EnableEvents = True End If On Error GoTo 0 End Sub