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

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

في النموذج المستمر اسهل طريقة باستخدام التنسيق الشرطي للوصول للنتيجة سواء من خلال قيمة حقل او من خلال حقل id وهذا الطريقة التي عملتها اضفت حقل id وجعلته مخفي ثم عملت تنسيق شرطي id=1 ولكل حقل في النموذج المستمر اغير رقم id طريقة بسيطة ولكن تحتاج عملها بعدد الالوان التي لديك لديك 11 لون انا عملت اربعة حقول وبامكانك عملها بنفس الطريقة ربما يمكن عملها بطريقة اخرى ولكن ليس لدي طولة البال في التجريب تحياتي تطبيق لون(2).accdb

وعليكم السلام 🙂 1. اضافة جميلة وملف صوت مميز ، والاحلى انك جمعت المرفقات في مجلد واحد 🙂 2. انا كذلك كنت مستغرب من هذا ، وبحثت ولم اصل الى نتيجة ، وبعدها جرّبت واقتنعت 🙂 وكذلك للتجربة ، 1. افتح برنامجك ، 2. اذهب الى مجلد البرنامج ، احذف المجلد Tools ، ستجد بان الوندوز حذفه ، 3. رجاء ارجاع المجلد Tools مرة اخرى ، باستعمال Ctrl + Z ، 4. افتح اي من النموذجين Up او Dn ، 5. اذهب الى مجلد البرنامج ، احذف المجلد Tools ، ستجد بأنك لا تستطيع حذفه ، لأن الوندوز يستعمل ملف الخط ، 6. اغلق النموذج الذي فتحته ، 7. اذهب الى مجلد البرنامج ، احذف المجلد Tools ، وستجد ان الوندوز حذفه ، 8. رجاء ارجاع المجلد Tools مرة اخرى ، باستعمال Ctrl + Z ، من هنا نرى ، انه اذا كان الوندوز يستخدم ملف الخط ، فلن يحذف المجلد. 9. اعمل هذا التغيير على احد النموذجين Up او Dn ، Private Sub Form_Close() 'Call RemoveFonts(CurrentProject.Path & "\Tools\digital-7 (mono).ttf") Call RemoveFonts("digital-7 (mono).ttf") Call RemoveFonts("C:\Windows\Fonts\digital-7 (mono).ttf") End Sub 10. افتح النموذج ثم اغلقه ، 11. اذهب الى مجلد البرنامج ، احذف المجلد Tools ، ستجد بأنك لا تستطيع حذفه ، لأن الوندوز يستعمل ملف الخط ، من هنا عرفت انه لسبب ما 🙂 وللمحترفين ، هناك طريقة اخرى لمعرفة اذا قام الكود بحذف الخط من الوندوز ، باضافة Debug لمعرفة نتيجة عمل Api : 1 = تم حذف الخط ، 0 = لم يتم حذف الخط (ونلاحظ انه مرتين ، لأن الكود الاخير فيه حذف الخط من مسارين) : جعفر

اسف لم اجرب الكود السابق فقد كتبته على عجالة اليك التعديل على الكود Private Sub Command38_Click() If Me.CurrentRecord = Me.RecordsetClone.RecordCount Then Exit Sub DoCmd.GoToRecord acDataForm, Me.Name, acNext End Sub Private Sub Command39_Click() If Me.CurrentRecord = 1 Then Exit Sub DoCmd.GoToRecord acDataForm, Me.Name, acPrevious End Sub

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

موضوع شيق، هل جربتم اسخدام هذا الأمر؟ : Call Application.Run("DialogColor", vbBlue)

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

طيب استخدم الاكواد الاتية زر أمر التالى With Recordset If .AbsolutePosition = .RecordCount - 1 Then MsgBox "Sorry, this is the last Record. To create a new Record one click the Add New Record button.", vbInformation Exit Sub Else DoCmd.GoToRecord , , acNext End If End With زر أمر السابق With Recordset If .AbsolutePosition = 0 Then MsgBox "Sorry, this is the First Record", vbInformation Exit Sub Else DoCmd.GoToRecord , , acPrevious End If End With وبكده تنتهى مشكلة الرسالة المزعجة احنا ما يرضينا زعلك

واذا تسمح لي اخوي ابو احمد ، بجعل البرنامج تلقائيا يستخدم الخط ويحذفه عند الخروج من البرنامج (استخدمت هذه الطريقة في احد برامجي في لخط الباركود 🙂 ) ، وعليه ، صورة نموذجك بالخط الصحيح سيكون . والوحدة النمطية لإضافة وحذف الخط Private Declare PtrSafe Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" ( _ ByVal lpFileName As String) As Long Private Declare PtrSafe Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" ( _ ByVal lpFileName As String) As Long ' Public Function AddFonts(Font_Name_Path As String) Dim result As Long result = AddFontResource(Font_Name_Path) 'MsgBox Result & " fonts added" End Function Public Function RemoveFonts(Font_Name_Path As String) Dim result As Long result = RemoveFontResource(Font_Name_Path) 'MsgBox Result & " fonts added" End Function . وننادي الاضافة عند فتح النموذج ، ثم ننادي الحذف عند اغلاق النموذج: Private Sub Form_Open(Cancel As Integer) Call AddFonts(CurrentProject.Path & "\Digital_Font\digital-7 (mono).ttf") End Sub Private Sub Form_Close() Call RemoveFonts(CurrentProject.Path & "\Digital_Font\digital-7 (mono).ttf") End Sub . مع مراعاة اني عملت مجلد للخط "digital-7 (mono).ttf" اسميته Digital_Font في مجلد البرنامج . جعفر StopWatch.zip

كما العنوان عداد تنازلي بالميلي ثانية مع خيار بالتوقف المؤقت وخيار استئناف العد من جديد. StopwatchExample_01.accdb

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

تم تنقيح الكود فقط لإزالة بعض المتغيرات والسطور غير المطلوبة حاليا. StopwatchExample_06.rar

طريقة رائعة كما اعتدنا من استاذنا محمد لكن عند التركيز على الحقل يحصل تداخل في الالوان بعكس التنسيق الشرطي انظر للصورة تحياتي

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

اهلا بحضرتك اشتاقت اليكم نفسى كثيرا هذا تصوير للمرفق

لم أستطع أن أصل إلى الموضوع ، لو تزودني بالرابط فضلا وليس أمرا.

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ..اليك الكود التالي لاستدعاء الفواتير بشرط رقم الفاتورة .مع اضافة ظهور اشعار بوجودها مسبقا في حالة كتابة رقمها في جدول الادخال كما جاء في طلبك . الكود لم ارفعه هنا قد تمت اضافته في حدث شيت ( مستند قيد) وان شاء الله نكون انتهينا من الخطوة الثانية. Sub Find_MH() Set Sh1 = Worksheets("مستند قيد") Set sh2 = Worksheets("اليومية العامه") Dim lastrow As Long Dim Mh As Long Dim iCont As Integer Dim r As Integer Dim c As Integer Dim MH2 As Worksheet Dim MH3 As Worksheet Dim Trouve As Range Application.ScreenUpdating = False If Len(Range("d5").Value) = 0 Then ' '<--التحقق من وجود قيمة في خلية البحث MsgBox "المرجوا ادخال رقم الفاتورة" Exit Sub End If With Sheets("اليومية العامه") 'في عمود (D) شيت الفواتير اليومية'<--- التحقق من وجود رقم الفاتورة Set Trouve = .Range("d:d").Find(what:=Sheet1.Range("d5"), LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then MsgBox (" !!!رقم الفاتورة غير مسجل مسبقا") Exit Sub Else End If End With MH1 = Sh1.Range("D5").Value ' '<--- في حالة تحقق الشرط With sh2 lastrow = .Cells(.Rows.Count, "b").End(xlUp).Row '+ 1 Mh = WorksheetFunction.Match(MH1, .Range("D5:D" & lastrow), 0) + 4 iCont = WorksheetFunction.CountIf(.Range("D5:D" & lastrow), MH1) End With X = 3 For c = 2 To 2 Sh1.Cells(X, 4) = sh2.Cells(Mh, c).Value ' '<---عمود D ( التاريخ - رقم الفاتورة _ الشركة_ ' Sh1.Cells(X + 1, 4) = sh2.Cells(Mh, c + 1).Value 'sh1.Cells(X + 3, 4) = sh2.Cells(Mh, c + 3).Value ' '<--- تم تعويضها بمعادلة '''=SI(D3="";"";CONCATENER(TEXTE($D$5;"0##########");" - ";$D$4;" - "&TEXTE('مستند قيد'!D3;"mm-yyyy"))) Sh1.Cells(X + 1, 6) = sh2.Cells(Mh, c + 15).Value ' '<---عمود F Sh1.Cells(X + 3, 6) = sh2.Cells(Mh, c + 17).Value Sh1.Cells(X + 2, 6) = sh2.Cells(Mh, c + 16).Value Sh1.Cells(3, 6) = sh2.Cells(Mh, c + 14).Value Sh1.Cells(3, 2) = sh2.Cells(Mh, c + 10).Value ' '<---عمود B Sh1.Cells(4, 2) = sh2.Cells(Mh, c + 11).Value Sh1.Cells(5, 2) = sh2.Cells(Mh, c + 12).Value Sh1.Cells(6, 2) = sh2.Cells(Mh, c + 13).Value X = X + 1 Set MH2 = Worksheets("اليومية العامه") Set MH3 = Worksheets("مستند قيد") lastrow = MH2.Cells(Rows.Count, "F").End(xlUp).Row If MH2.FilterMode Then MH2.ShowAllData Worksheets("مستند قيد").Range("b9:F51").ClearContents ' '<---افراغ البيانات السابقة With MH2.Rows(6) ' '<--- تحديد رقم صف رؤؤوس الاعمدة ' '<--- تحديد عمود وجودة القيمة المبحوث عنها Row4 ___________________________________' '<--تحديد خلية البحث .AutoFilter Field:=4, Criteria1:=Worksheets("مستند قيد").Range("D5").Value ' ' <--- _____________________فلترة البيانات If MH2.Range("d6:d" & lastrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then MH2.Range("F7:J" & lastrow).SpecialCells(xlCellTypeVisible).Copy MH3.Range("b" & Rows.Count).End(3)(2) ' '<--- مكان اللصق MH3.Range("A9:G51").Borders.LineStyle = xlContinuous ' '<---تسطير الجدول End If .Parent.AutoFilterMode = False ' '<---الغاء الفلترة End With Next Application.ScreenUpdating = True End Sub واليك اخي كود اضافي للترحيل من شيت الفاتورة الى شيت الفواتير اليومية ربما تحتاجه يوما ما. Sub TARHIL2() Dim LastRowF1 As Integer Dim NextRowF2 As Integer Dim RowCount As Integer Dim rngF1 As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("مستند قيد") Set Sh2 = Worksheets("اليومية العامه") Dim Arr As Variant Arr = Array([b3], [d3], [f3], [b4], [d4], [f4], [f5], [f6]) For i = 0 To 7 If Arr(i) = "" Then MsgBox "المرجوا ادخال البيانات" Arr(i).Select Exit Sub End If Next i With Sh1 NextRowF2 = Sh2.Cells(Rows.Count, 6).End(xlUp).Row + 1 If NextRowF2 < 9 Then NextRowF2 = 7 LastRowF1 = .Cells(Rows.Count, 2).End(xlUp).Row - 1 Set rngF1 = .Range(.Cells(9, "B"), .Cells(LastRowF1, "g")) RowCount = rngF1.Rows.Count Sh2.Cells(NextRowF2, "F").Resize(RowCount, rngF1.Columns.Count).Value = rngF1.Value Sh2.Cells(NextRowF2, "B").Resize(RowCount).Value = .Range("d3").Value Sh2.Cells(NextRowF2, "C").Resize(RowCount).Value = .Range("d4").Value Sh2.Cells(NextRowF2, "d").Resize(RowCount).Value = .Range("d5").Value Sh2.Cells(NextRowF2, "E").Resize(RowCount).Value = .Range("d6").Value Sh2.Cells(NextRowF2, "L").Resize(RowCount).Value = .Range("b3").Value Sh2.Cells(NextRowF2, "M").Resize(RowCount).Value = .Range("b4").Value Sh2.Cells(NextRowF2, "N").Resize(RowCount).Value = .Range("b5").Value Sh2.Cells(NextRowF2, "O").Resize(RowCount).Value = .Range("b6").Value Sh2.Cells(NextRowF2, "P").Resize(RowCount).Value = .Range("F3").Value Sh2.Cells(NextRowF2, "Q").Resize(RowCount).Value = .Range("F4").Value Sh2.Cells(NextRowF2, "R").Resize(RowCount).Value = .Range("F5").Value Sh2.Cells(NextRowF2, "S").Value = .Range("F6").Value Sh1.Range("b2").Value = Sh2.Range("d" & Rows.Count).End(xlUp).Value + 1 End With End Sub بالتوفيق. في انتظار الرد بعد التجربة . فاتورة_MH.xlsm

أكيد أسمح ، وبما أنك توسعت وهذا يخالف أسلوبي حيث أنا أحب التركيز على الفكرة الأساس 🙂 فأنا مشيت مع التيار وتوسعت أيضا بإضافة ملف الصوت. سؤالي لك : في إضافة الخط نشير إلى مسار الملف واسمه وهذا منطقيا سليم ، فلماذا عند الإزالة نشير إلى نفس المسار عند الإضافة؟!! StopwatchExample_04.rar

ProgHanta.rar

هذا مثال جميل قد يقيدك ارقام الالوان.rar

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

تمت التعديلات التالية: - الأخذ في الاعتبار تغير التاريخ عند الساعة 12 ليلا. - تبديل الخط لصندوق للعداد مع وضع عنوان مصدر الخط لمن يريد انزاله وحفظه في مجلد الخطوط للويندوز. - أخذ ملاحظة عزيزنا جعفر بإبقاء الوقت عند الإيقاف النهائي للعد واستبداله بالتعامل مع زر الإيقاف المؤقت. - بعض التحسينات في الكود. StopwatchExample_02.accdb

اسمه Digital ، وعند البحث عن خط digital ، اول رابط حصلت عليه https://www.1001fonts.com/digital-7-font.html جعفر

وعليكم السلام ورحمة الله وبركاته الجواب كما يلي: إن أردت تطبيق المعادلة على كل المعطيات لديك ضع هذه المعادلة ،واسحب نزولاً. =IF(AND(W6=12;V6=1;U6>=500;T6>=1800;S6<=3600);35%;IF(AND(W6=18;V6=2;U6>=750;T6>=3650;S6<=5500);40%;IF(AND(W6=24;V6=3;U6>=1000;T6>=5550;S6<=7500);45%;IF(AND(W6=30;V6=4;U6>=1500;T6>=7550;S6<=10000);50%)))) أرجو أن تنتفع به . تقبل تحياتي. طلب مساعدة.xlsx

السلام عليكم 🙂 عمل مبدع ، وكود نظيف وسهل التتبع 🙂 الشيء الوحيد اللي عدّلت فيه هو ، عند النقر على ايقاف الساعة ، كانت تختفي ، فقمت بإيقاف السطر 🙂 Me.txtRemainTime = Null جعفر

السلام عليكم هذا حل آخر بالمعادلات دون عمود مساعد والمعادلات هي معادلات صفيف (يجب تأكيدها بـ CTRL+SHIFT+ENTER)... Book2_2.xlsx

ان شاء الله بس ارسل قاعدة البيانات

ايضا ممكن استخدامها لفلترة السجلات باستخدام اي عدد من الحقول وبالتالي بكود مختصر ومربع نص واحد ممكن الفلترة باسم الموظف اور رقمه او مسمى الوظيفة نعم ممكن عملها بطرق اخرى مثلا في الاستعلام او بالكود ولكن هذه الطريقة تختصر علينا صف المعايير رووووعة Dim strWhere As String strWhere = "[Field1]&[Field1]&[Field3] like '*" & [Text1] & "*'" Me.balancesub.Form.Filter = strWhere Me.balancesub.Form.FilterOn = True هنا الفلترة من خلال ثلاث حقول بواسطة مربع نص واحد ☝️ واعتذر من الاستاذ قدور بالخروج عن الموضوع تحياتي

الآن فقط انتبهت انك: تبحث في حقلين عن طريق حقلين ، شيء جميل جعفر

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