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

احوانى واخواتى ابنائى وبناتى وكل مجتمع اوفسينا التقيكم مجدداً فى هذا الدرس الجديد اخترت له اسم الثلاثيه العجيبه upper lower proper(3).rar

السلام عليكم دالة استخراج تاريخ الميلاد او النوع او المحافظة من الرقم القومي ثلاثة معطيات بدالة واحدة Option Explicit ' بسم الله الرحمن الرحيم ' ******************** ' دالـــــــــــــــة ' Kh_Date_Sex_Province ' ( استخراج تاريخ الميلاد او النوع (ذكر - انثى ' او المحافظة من الرقم القومي '============================================== ' MyTest ' اذا كانت = 1 تقوم باستخراج تاريخ الميلاد ' اذا كانت = 2 تقوم باستخراج النوع ' اذا كانت = 3 تقوم باستخراج المحافظة '---------------------------------------------- ' MyProvinces في متغير الجدول ' العمل لم يستكمل بعد ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ ' بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة ' : مثال على ذلك ' "01/القاهرة" '============================================== '----------------------------------------------------------------- Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte) Dim MyProvinces As Variant Dim r As Integer Dim yy As String Dim ty As String * 1 Dim d As String * 2, m As String * 2, y As String * 2 _ , x As String * 2, xx As String * 2 '============================================== ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _ , "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _ , "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _ , "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح") '============================================== Kh_Date_Sex_Province = "" On Error GoTo 1 If Len(Trim(MyNumber)) = 0 Then GoTo 1 End If If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then Kh_Date_Sex_Province = "Error_MyNumber" GoTo 1 End If If MyTest = 1 Then d = Mid(MyNumber, 6, 2) m = Mid(MyNumber, 4, 2) y = Mid(MyNumber, 2, 2) ty = Left(MyNumber, 1) Select Case ty Case "2": yy = y Case "3": yy = "20" & y Case Else: yy = "" End Select If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d) ElseIf MyTest = 2 Then If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _ yy = "ذكر" Else yy = "انثى" Kh_Date_Sex_Province = yy ElseIf MyTest = 3 Then x = Mid(MyNumber, 8, 2) For r = LBound(MyProvinces) To UBound(MyProvinces) xx = MyProvinces(r) If x = xx Then Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3) Exit For End If Next End If 1: End Function بالنسبة لمعطيات المحافظات لم تستكمل بعد ويمكنك اضافة المحافظات المتبقية حسب ما شرحت بالكود خبور خير دالة استخلاص تاريخ الميلاد و النوع و المحافظة من الرقم القومي.rar

أخى مهند هذا هو شرح كود الاخفاء Sub ragab() 'تعريف المتغيرات Dim rng As Range Dim cl As Range Dim LC As Integer 'ايقاف اهتزاز الشاشة لتسريع الكود Application.ScreenUpdating = False 'تحديد رقم آخر عمود فارغ فى الصف الأول LC = Range("A1").End(xlToRight).Column 'تحديد المدى بالخلايا المحتوية على المجموع فى الصف الحادى عشر Set rng = Range(Cells(11, 2), Cells(11, LC)) 'حلقة تكرارية لمعرفة الخلايا المحتوية على القيمة صفر فى المجموع For Each cl In rng If cl.Value = 0 Then 'اخفاء عمود الخلايا المحتوية على صفر cl.EntireColumn.Hidden = True End If Next ' ارجاع اهتزاز الشاشة Application.ScreenUpdating = True End Sub وبالنسبة لكود الاظهار فهو يقوم بالعملية العكسية

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

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

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

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

آسف على التأخير مرفق الملف بعد زالة التكرارات و اعتقد انه نفس نتيجه المبدع أ ياسر خليل بالتوفيق تحميل الملف من هنا

أخي الكريم يرجى تغيير اسم الظهور ليعبر عن شخصكم الكريم إليك الكود التالي عله يفي بالغرض Sub CountCells() Dim Ws As Worksheet, Cel As Range, I As Integer Set Ws = ActiveSheet Application.ScreenUpdating = False For Each Ws In ThisWorkbook.Worksheets For Each Cel In Ws.Range("I7:I" & Ws.Cells(Rows.Count, "I").End(xlUp).Row) If GetCellColorForReals(Cel) = 65535 Then I = I + 1 Next Cel Next Ws If I = 0 Then MsgBox "لا يوجد خلايا ملونة", 64 Else MsgBox "عدد الخلايا الملونة يساوي " & I End If Application.ScreenUpdating = False End Sub Function GetCellColorForReals(R As Range) As Long GetCellColorForReals = R.DisplayFormat.Interior.Color End Function تقبل تحياتي

..... شاهدوا المرفق أخوكم عماد الحسامي

اخى فى الله الاستاذ / احمد السلام عليكم الاجمل من الملف هو لقائى بحضرتك فبارك الله فيكم وفى عمرك لاأعتقد أن هناك مشكلة بالخصم ولا بالاضافة فضلا قم بحذف جميع القيم ومن ثم 1000 فى الاضافة ثم 200 فى الخصم إذن الحالى = 800 ثم على نفس الـــ 1000 سنضيف 100 إذن الحالى = 900 ثم فى الخصم 400 إذن الحالى = 500 تشرفت بكم أخى الفاضل ***** تقبل وافر تقديرى واحترامى **** وجزاكم الله خيرا

أخى الفاضل / nasersaeed أخى الفاضل / السمالوطى جزاكم الله خيرا على هذه الكلمات الطيبة

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

السلام عليكم انا فكرتي تختلف عن فكرة أخي سعيد ، وهذه ميزة أكثر من مشاركة في موضوع واحد فكرتي هي: 1. عمل جدول مؤقت باسم tbl_Temp ، ونُدخل فيه جميع الاشهر ، ابتداء من الشهر بعد تاريخ التوظيف ، الى الشهر الماضي ، لكل موظف ، 2. ثم نستعمل الاستعلام في مقارنة هذه الاشهر ، مع الاشهر المدفوعه ، ونطلب من الاستعلام ان يعطينا قائمة بالاشهر الغير موجودة الكود التالي يعمل العمل رقم 1: Private Sub cmd_Go_Click() On Error GoTo err_cmd_Go_Click Dim rstF As DAO.Recordset Dim rstT As DAO.Recordset 'empty tbl_Temp CurrentDb.Execute ("Delete * From tbl_Temp") 'table To Set rstT = CurrentDb.OpenRecordset("Select * From tbl_Temp") 'table From Set rstF = CurrentDb.OpenRecordset("Select * From akad_amel") rstF.MoveLast: rstF.MoveFirst RC = rstF.RecordCount 'Loop from table From, 'and get the w-code, and his starting date For i = 1 To RC Date_From = rstF!bad_akd 'Starting date Date_To = DateSerial(Year(Date), Month(Date), 0) 'Last month How_Many_Months = DateDiff("m", Date_From, Date_To) 'How many months in-between Last_Day_Of_Last_Month = DateSerial(Year(Date_From), Month(Date_From), 30) 'Last_Day_Of_Last_Month 'we will generate All the months for each Employee, from his start date to Last month For j = 1 To How_Many_Months 'start adding rstT.AddNew rstT!w_code = rstF!w_code 'w_code rstT!iDate = DateAdd("m", j, Last_Day_Of_Last_Month) 'the month rstT.Update Next j rstF.MoveNext Next i rstF.Close: Set rstF = Nothing rstT.Close: Set rstT = Nothing MsgBox "Done" Exit Sub err_cmd_Go_Click: If Err.Number = 3021 Then 'No Records Exit Sub Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub ثم النتيجة تكون في الاستعلام qry_Temp Without Matching raetb_tamb ، والذي يُفضل ان تعمل تقرير على اساسه ** ملاحظة ، بسبب استعمال الجدول المؤقت ، والذي يتم حذف جميع بياناته واضافة بيانات جديدة ، هذا يجعل حجم قاعدة البيانات تكبر ، فيجب استخدام الضغط والاصلاح بين كل فترة لإرجاع الحجم الى حقيقته جعفر 240.الشهر الغير موجود.mdb.zip

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

انا ايضا جربت الكود ولم تحدث معي اي مشكلة ... شكرا أخي ياسر على الكود الإكثر من رائع .. مع شكري للإستاذ رجب جاويش

ألف ألف مبرووووك.. وعقبال ال100 سنة وابن ابن الحفيد

أخى ياسر أخى شبكة النبراس الإسلامية الكود يعمل عندى بشكل ممتاز تسلم ايديك أخى ياسر أنا اعمل على أوفيس 2010

أخى الفاضل جرب هذا الكود لعله يكون كما تريد Sub نقل() Dim Rng1 As Range, Rng2 As Range Dim LastRow2 As Long, LastRow3 As Long Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet '=========================================================== Set sh1 = Sheets("B"): Set sh2 = Sheets("D") Set sh3 = Sheets("Archive") Set Rng1 = sh1.Range("D8:BM39") Set Rng2 = sh1.Range("A40:BL40") '=========================================================== Application.ScreenUpdating = False LastRow2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1 LastRow3 = sh3.Range("A" & Rows.Count).End(xlUp).Row + 1 '=========================================================== Rng1.Copy sh3.Range("A" & LastRow3).PasteSpecial Paste:=xlPasteValues Rng2.Copy sh2.Range("A" & LastRow2).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ترحيل بيانات.rar

السلام عليكم تفضل أخى كود الاخفاء Sub ragab() Dim rng As Range Dim cl As Range Dim LC As Integer Application.ScreenUpdating = False LC = Range("A1").End(xlToRight).Column Set rng = Range(Cells(11, 2), Cells(11, LC)) For Each cl In rng If cl.Value = 0 Then cl.EntireColumn.Hidden = True End If Next Application.ScreenUpdating = True End Sub وهذا كود الاظهار Sub ragab1() Dim rng As Range Dim LC As Integer Application.ScreenUpdating = False LC = Range("A1").End(xlToRight).Column Set rng = Range(Cells(11, 2), Cells(11, LC)) rng.EntireColumn.Hidden = False Application.ScreenUpdating = True End Sub Book2.rar

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

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

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

بارك الله فيك يا حبيبي مجهود لا يقال عنه إلا أكثر من رائع

حبيبي الموضوع بسيط جدا يتم عمل مشاركة للملف كما موضح بالفيديو yasser.rar

مجهود رائع و واضح ... عاشت ايدك

شكرا الاستاذ رجب جاويش ولاثراء الموضوع وللتعلم تفضل بعض طرق التصميم http://www.officena.net/ib/topic/64832-اعمل-شاشة-دخول-برنامجك-بنفسك-وسيبك-من-التقليد/ وبعدين http://www.officena.net/ib/topic/65092-شرح-عمل-صلاحيات-للدخول-على-شيتات-داخل-ملف-الاكسيل/ وشكرا

سبق ان رأيت مثل هذه الفكرة ولكن في ملف للاكسيل .. نتمنى ان نرى مثلها في الاكسس

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

وعليكم السلام ورحمة الله أهلا بك أخي.. تفضل الجمع بهذه الدالة وانظر النموذج بمرفقك بعد وضع بيانات تجريبية =DCount("Job";"Data";" Job = 'General Manager'") test2.rar

أخي الكريم مهند لما لا تطرح موضوع جديد لتجد استجابة أكثر مع التوضيح التام لطلبك مع إرفاق لشكل النتائج المتوقعة إذا تطلب الأمر أخي الحبيب رجب جاويش حاول أن تبتعد قدر الإمكان عن الحلقات التكرارية لما لها من أثر في بطء عمل الكود خصوصاً إذا كانت البيانات كبيرة ما رأيك بفكر جديد وهو استخدام خاصية الفلترة ..جرب الكود التالي Sub HideRowsUsingFilterMethod() Dim Rng As Range Application.ScreenUpdating = False On Error Resume Next With ActiveSheet .AutoFilterMode = False .Range("C12:C65512").AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="" Set Rng = .Range("C13:C65512").SpecialCells(xlCellTypeVisible) .AutoFilterMode = False Rng.EntireRow.Hidden = True End With Application.ScreenUpdating = True End Sub تقبل تحياتي

أخي الكريم أبو عبد الرحمن على حسب علمي لا يوجد خاصية صناديق الاختيار داخل قائمة الكومبوبوكس جرب الملف التالي عله يكون المطلوب لك ..سيتم إنشاء صناديق اختيار بمجرد تشغيل الفورم .. قم فقط بإنشاء زري أمر أحدهما باسم cmdExit للخروج من الفورم والآخر باسم cmdReport لإظهار الحقول المطلوبة فقط .. أرجو أن يفي بالغرض Private Sub cmdReport_Click() Dim Ctrl As Control, FoundCol Sheet1.Columns("A:T").EntireColumn.Hidden = False Sheet1.Columns("A:R").EntireColumn.Hidden = True For Each Ctrl In UserForm1.Controls If TypeName(Ctrl) = "CheckBox" Then If Ctrl.Value = True Then FoundCol = Application.Match(Ctrl.Caption, Sheet1.Rows(1), 0) If IsNumeric(FoundCol) Then Columns(FoundCol).Hidden = False End If End If Next Ctrl Application.Goto Sheet1.Range("A1") End Sub Private Sub UserForm_Initialize() Dim LastColumn As Long Dim I As Long Dim chkBox As MSForms.CheckBox LastColumn = 18 For I = 1 To LastColumn Set chkBox = Me.Controls.Add("Forms.CheckBox.1", "CheckBox_" & I) chkBox.Caption = Sheet1.Cells(1, I).Value chkBox.Left = 20 chkBox.Top = 5 + ((I - 1) * 20) Next I End Sub Private Sub cmdExit_Click() Unload Me End Sub تقبل تحياتي Create CheckBoxes On UserForm By Cells In Specific Range YasserKhalil.rar

أخى ياسر بجد والله أنا اقف مبهورا أمام ابداعاتك لأتعلم منها وفعلا فكرة جميلة فكرة النقاش لتبادل الخبرات وبالنسبة للكود ما رأيك فى هذا الاختصار Sub ragab() Set Sh = ورقة3 x = [g13] T = Application.Match(x, Sh.Columns("G:G"), 0) If Not IsNumeric(T) Then T = Sh.[G1000].End(xlUp).Row + 1 Sh.Range("B" & T).Resize(1, 10).Value = Range("B13").Resize(1, 10).Value End Sub

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

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

اذا كنت تقصد منع تحريك الشكل او تغيير حجمه انظر الصور التالية

السلام عليكم هذه بعض الفوائد: 1- تستطيع العمل على واجهات جميلة جدا تبهر بها المستخدم. 2- سهولة التعامل مع قاعدة البيانات من اضافة ,حذف ,تعديل , ..... الخ. 3- سهولة التحكم بالبيانات وكيفية عرضها للمستخدم. 4- سرعة التعامل مع البيانات. 5- أمنية عالية جدا لقاعدة البيانات. 6- تستطيع انشاء قاعدة بيانات أكسس وانشاء الجداول والحقول والتعامل معها عن طريق الـVisual

وتكون النتيجة كما بالملف المرفق spin.rar

شكرا أستاذ عبد الفتاح

وعليكم السلام أخي الغالي أبا الحسن والحسين إضافة لما تفضلت به في الملف المرفق من الكود ..إضافة بسيطة جداً لكي يعمل الكود على كلا النظامين 32 بت و64 بت (حيث أن الملف المرفق في المشاركة الخاصة بك سيعمل على 64 بت فقط) استبدال أسطر الإعلانات العامة في الموديول بهذه الأسطر #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" ( ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "User32" ( ByVal hwnd As Long) As Long #End If ليصبح الكود النهائي بهذا الشكل (الكود يوضع في حدث الفورم ) #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hwnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" ( ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "User32" ( ByVal hwnd As Long) As Long #End If Sub RemoveCaption(objForm As Object) Dim lStyle As Long Dim hMenu As Long Dim mhWndForm As Long If Val(Application.Version) < 9 Then mhWndForm = FindWindow("ThunderXFrame", objForm.Caption) 'XL97 Else mhWndForm = FindWindow("ThunderDFrame", objForm.Caption) 'XL2000+ End If lStyle = GetWindowLong(mhWndForm, -16) lStyle = lStyle And Not &HC00000 SetWindowLong mhWndForm, -16, lStyle DrawMenuBar mhWndForm End Sub Private Sub CommandButton1_Click() Unload Me End Sub Private Sub UserForm_Initialize() Call RemoveCaption(Me) End Sub ونقطة أخيرة للاستفادة الكاملة من الكود يمكنك وضع الإعلانات العامة والإجراء المسمى RemoveCaption في موديول عادي ..بينما يوضع حدث زر الأمر وحدث بدء تشغيل الفورم في حدث الفورم أي يمكن الفصل بينهما تقبل تحياتي

أخي الكريم نور وحيد إليك الملف التالي إثراءً للحل Multi Data Validation List YasserKhalil.rar أخي الحبيب ياسر العربي حلك رائع جداً ..إضافة بسيطة لحلك هو إمكانية جعل القوائم كلها مطاطية أي غير ثابتة إليك حل المتميز ياسر العربي بإضافة بسيطة وهي جعل القوائم ديناميكية Multi Data Validation List Araby.rar

بسم الله الرحمن الرحيم اليوم سنشرح عمل شاشة دخول ولكن باسم مستخدم وكلمة مرور بسم الله نبدأ بالشكل الموضح يوجد المشار لهم بالسهم الأخضر 7 label السهم الأحمر 1 textbox السهم الأسود 1 combobox وزر دخول وزر خروج وطبعا اتنين image لشعار الشركة بعد تصميم نفس الشكل السابق نقوم بعمل شيت جديد اسمه users كما بالصورة بعد تسمية الشيت وخصوصا برمجيا مثل التحديد الأحمر نضيف البيانات كالأتي نيجي بقي للاكواد اولا كما تعلمنا في الدرس السابق نقوم بوضع هذه الاكواد في اليوزرفورم في general)) Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 في حدث تهيئة الفورم Private Sub UserForm_Initialize() Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) End Sub في حدث الاغلا ق Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If unloadmode = vbFormControlMenu Then Cancel = True MsgBox "غير مسموح" End If End Sub اما في حدث تنشيط الفورم فنقوم باضافة اكواد ربط الليبل الخاصة ببيانات الشركة بالخلايا التي تحتوي علي البيانات Private Sub UserForm_Activate() Application.WindowState = xlMaximized Application.Visible = False Label1.Caption = users.[e1] Label2.Caption = users.[e2] Label3.Caption = users.[e3] With Me .Height = Application.Height .Width = Application.Width .Left = Application.Left .Top = Application.Top End With End Sub وفي زر الخروج Private Sub CommandButton2_Click() ActiveWorkbook.Save ActiveWorkbook.Close End Sub تبقي لنا الكود الاهم وهو زر الادخال Private Sub CommandButton1_Click() On Error GoTo 86 If Application.WorksheetFunction.VLookup(ComboBox1.Value, users.Range("a2:l0"), 2, 0) = TextBox1.Text Then Me.Hide Application.Visible = True MsgBox ComboBox1.Value & " مرحبا بك/ ", , "elmalak_elhazen_yasser@yahoo.com" Else 86 Label7= Label7+ 1 MsgBox " لقد استخدمت " & Label7 & " محاولة من اصل 5 محاولات" ,vbCritical, "elmalak_elhazen_yasser@yahoo.com" If Label7= 5 Then MsgBox "لقد استنفذت جميع المحاولات" ActiveWorkbook.Save ActiveWorkbook.Close End If End If End Sub استخدمنا هنا دالة vlookup للبحث والمقارنة عن المستخدم وكلمة المرور ان لم يحقق الشرط يتم التحويل الى عدد المحاولات ومنها الى اغلاق البرنامج وطبعا زي كل مره ننسى نحط كود في حدث فتح الملف Private Sub Workbook_Open() Userform1.Show End Sub وطبعا لسه مش ربطنا الكمبوكس اللي فيها اسم المستخدم عشان نسهل عليكم نعملها بالطريقة التقليدية وبعدين نبقي نعملها باحترافيه شوية نحدد الكمبوكس ونكتب اسم الشت والرينج اللي فيه اسم المستخدم كما موضح بالصورة المظلل بالاحمر الى شاشة دخول اخرى باذن الله مع تحياتي ياسر العربي اي مشاكل تواجهكم يرجى ابلاغنا لحلها

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

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

أستاذى الحبيب / عبد الله باقشير دائما أتشرف بمرور أستاذى الحبيب وكلماته المشجعة تقبل أرق تحياتى وتقديرى

بارك الله فيك ورحم الله والديك هل عندك ملفات خاصة بالتربية والتعليم من مرتبات وشهادات وكننرولات وماشابه ذلك

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

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

وهاي كمان برامج ولسى الخير قادم أنا شايف إنو لغاية الآن ما في لسى حد دخل على المنتدى و هيك راح تكون مفاجئة كبيرة للكل WriteNumber2000.zip ProgressBar2000.zip ColorRecords2000.zip Keyboard2000.zip FindAndFilter2000.zip HideMsgBoxFail2000.zip Animation2k.zip

وهنا المزيد المزيد ،،،، سأقوم بوضع برامج بشكل يومي وبشكل كبير ، ، ، بس أهم شي زي ما وصيتكم الردود و الدعاء accarch154.zip accarch161.zip