Foksh

هههههههه ، يا عيني عليك ، اكتشفتها بنفسك .. جرب التعديل الأخير على أكثر من احتمال :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape, c As Range Dim r As Long, i As Long, n As Long Dim usedRows As Collection Dim dayCount As Long, perDay As Long, extra As Long Dim rr As Variant, lastCol As Long Dim hasLesson As Boolean Dim lessonCount As Long Dim circlesThisDay As Long If x <= 0 Then Exit Sub Set usedRows = New Collection lessonCount = 0 For r = startRow To endRow hasLesson = False For i = 3 To 10 If Cells(r, i).Value <> "" Then hasLesson = True lessonCount = lessonCount + 1 End If Next i If hasLesson Then usedRows.Add r Next r dayCount = usedRows.Count If dayCount = 0 Then Exit Sub n = 0 If x = lessonCount Then For r = startRow To endRow For i = 10 To 3 Step -1 If Cells(r, i).Value <> "" Then Set c = Cells(r, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 n = n + 1 If n = x Then Exit Sub End If Next i Next r ElseIf x > lessonCount Then Do While n < x For r = startRow To endRow For i = 10 To 3 Step -1 If Cells(r, i).Value <> "" Then Set c = Cells(r, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 n = n + 1 If n = x Then Exit Sub End If Next i Next r Loop Else perDay = x \ dayCount extra = x Mod dayCount If x > 10 And x < lessonCount Then extra = extra + 1 For Each rr In usedRows circlesThisDay = perDay If extra > 0 Then circlesThisDay = circlesThisDay + 1 extra = extra - 1 End If lastCol = 0 For i = 10 To 3 Step -1 If Cells(rr, i).Value <> "" Then lastCol = i Exit For End If Next i For i = lastCol To 3 Step -1 If Cells(rr, i).Value <> "" And circlesThisDay > 0 Then Set c = Cells(rr, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 circlesThisDay = circlesThisDay - 1 n = n + 1 If n = x Then Exit Sub End If Next i Next rr End If End Sub

أنصحك أخي @بلانك ، بتجربة إحتمالات كثيرة على النتيجة والتحقق منها 100% 😉

علني اكون قد فهمت المنطق جيداً .. تفضل التعديل :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim r As Long, i As Long, n As Long Dim c As Range Dim usedRows As Collection Dim dayCount As Long, perDay As Long, extra As Long Dim rr As Variant, lastCol As Long Dim hasLesson As Boolean If x <= 0 Then Exit Sub Set usedRows = New Collection For r = startRow To endRow hasLesson = False For i = 3 To 10 If Cells(r, i).Value <> "" Then hasLesson = True Exit For End If Next i If hasLesson Then usedRows.Add r Next r dayCount = usedRows.Count If dayCount = 0 Then Exit Sub perDay = x \ dayCount extra = x Mod dayCount n = 0 For Each rr In usedRows Dim circlesThisDay As Long circlesThisDay = perDay If extra > 0 Then circlesThisDay = circlesThisDay + 1 extra = extra - 1 End If lastCol = 0 For i = 10 To 3 Step -1 If Cells(rr, i).Value <> "" Then lastCol = i Exit For End If Next i For i = lastCol To 3 Step -1 If Cells(rr, i).Value <> "" And circlesThisDay > 0 Then Set c = Cells(rr, i) Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 circlesThisDay = circlesThisDay - 1 n = n + 1 If n >= x Then Exit Sub End If Next i Next rr End Sub

لم افهم بالضبط !!!! يعني النتيجة المطلوبة ، أنه حتى يوم الاربعاء الحصة 2-3 تكون عليها دائرة ؟؟؟ بدلاً من الحصة الخامسة ليوم الإثنين !!!

تمام .. استبدل الدالة الرئيسية بالتالية ، وجربها على ملفك بعد إزالة الدوائر السابقة طبعاً :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim i As Long, r As Long, n As Long Dim c As Range If x <= 0 Then Exit Sub i = 10 n = 0 Do While i >= 2 For r = endRow To startRow Step -1 Set c = Cells(r, i) If c.Value <> "" Then Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) n = n + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 If n >= x Then Exit Sub End If Next r i = i - 1 Loop End Sub

وعليكم السلام ورحمة الله وبركاته .. على حسب ما فهمت أن المقصود هو أكواد رسم الدوائر كما في ملفك المرفق ، صحيح ؟؟ طيب بدايةً .. وللتوضيح :- إذا كانت الأعمدة تتغير ( ليس دائماً العمود 10 ) ، هنا أخي بلانك يمكنك إضافة معامل رابع للدالة DrawCircles لتحديد آخر عمود ، أو استخدام نطاق أكثر حيوية . لكن بناءً على الأكواد الحالية من ملفك المرفق ، أعتقد أن i = 10 و i >= 2 متغيران ثابتان لجميع الحالات . صحيح ؟؟ إذا كان ما فهمته صحيح .. فاستعمل ما يلي :- الدالة الرئيسية :- Sub DrawCirclesByFoksh(ByVal x As Integer, ByVal startRow As Integer, ByVal endRow As Integer) Dim Shp As Shape Dim i As Long, s As Long, n As Long Dim c As Range If x <= 0 Then Exit Sub i = 10 n = 0 Do While i >= 2 For Each c In Range(Cells(startRow, i), Cells(endRow, i)) If c.Value <> "" Then Set Shp = Sheet1.Shapes.AddShape(msoShapeOval, _ c.Left, c.Top, c.Width, c.Height) n = n + 1 Shp.Fill.Visible = msoFalse Shp.Line.Weight = 1 Shp.Line.ForeColor.SchemeColor = 10 If n >= x Then Exit Sub End If Next c i = i - 1 Loop End Sub ثم تستدعيها من خلال الزر وبتمرير المجموعات التي تريدها ولك الحرية في ذلك ، بهذا النمط :- Sub AddCirclesMain() Call DrawCirclesByFoksh(Range("n9").Value, 10, 14) Call DrawCirclesByFoksh(Range("n17").Value, 18, 22) Call DrawCirclesByFoksh(Range("n25").Value, 26, 30) End Sub طبعاً ستستدعي الدالة AddCirclesMain في زر رسم الدوائر .

وعليكم السلام ورحمة الله وبركاته .. جري استخراج القيم من الخليتين كنص . في أي خلية تريدها استخدم المعادلة التالية :- =TEXT(C3,"yyyy/mm/dd") & " " & TEXT(B3,"yyyy/mm/dd")

حاول تغيير اسم الخط الذي تستخدمه لتنسيق هذا العنصر 🤔

أخي بلانك .. لإجراءاتكم بنقل الإجابة إلى الحل الأخير . ما لم يكن هناك أي تعديل آخر .

أراك قد عدت الى استعمال الساعة في برامجك أخي جعفر .. رغم مقولتك :- وهنا أراك تبحث عن ثغرة برأس الإبرة .😉. علك قد تجد حلاً في يوم من الأيام .. لأن الفكرة التي نفذناها نفذت خصيصاً لكي تغنيك عن طريقة =Now() وفكرة التايمر الميتة التي طرحتها وتشتكي منها أصلاً ! بالتوفيق 😇

مبارك عليك الحل .. وعذراً لعدم المتابعة معك في وقتها ، بس كنت خارج من الشغل للأسف .. في المرفق اللي رفعتهولك ، كان فعلاً يتم التنفيذ على الإمتدادين MDB و ACCDB من إصدارات 2007 وما فوق .. لكنك بحثت عن فكرة زرين لكل وظيفة ، وهذا كان يسيراً جداً من خلال الفكرة اللي طرحتها .. ولكن كل الطرق تؤدي إلى روما - ما دامت روما قريبة - .. وفعلاً نسختك اللي رفعتها ما اشتغلتش عندي أنا كمان وده اللي خلاني أطلع وقلت بجرب على كمبيوتر تاني .. 👍🏻

أصغر همومك أخي أحمد .. كمثال ؛ في حدث بعد التحديث للعنصر OptMain ، جرب الفكرة التالية أو كما تريد لحاجتك :- Private Sub OptMain_AfterUpdate() If Me.OptMain.Value = 1 Then Me.Btn_Doit.Caption = "إلغاء تفعيل مفتاح الشيفت" Else Me.Btn_Doit.Caption = "تفعيل مفتاح الشيفت" End If End Sub

اهاااا .. فهمتك الحين .. يعني كتشبيه بسيط !! كالميكانيكي الذي يريد إصلاح ماتور سيارة أثناء سيرها .. بلهجتنا الأردنية = كيف .. ليش .. وين .. متى ؟؟ هو حر يدبر راسه ، و يفك الماتور ويصلحه والسيارة شغالة . وبما أنك مصر على الوقوف عند عقدة آكسيس ، لم لا تنقل حدثك من عند الوقت الى دالتي المتواضعة ( NativeTimerCallback ) 😎 !! وبما أن كود مراقبة المجلدات لا يعتمد على التعديل الرسومي للواجهة ، فإنه سيستمر بالعمل أخي جعفر ، بل ومراقبة المجلدات كل ثانية في الخلفية ، حتى وأنت داخل محرر الأكواد ، تستطيع تكتب أكوادك بكل هدوء وسلام 😏 ..

مجهود جميل أستاذ @عبدالله بشير عبدالله ، ومتابعة جيدة جداً منكم جميعاً .. تم نقل الإجابة إلى آخر مرفق . وعله يكون الشافي لأخينا @بلانك

وعليكم السلام ورحمة الله وبركاته .. أهلاً بك معلمي الفاضل @jjafferr ، وأشكرك جداً على هذه الملاحظة الدقيقة والمهنية . نقطتك في محلها تماااااماً ؛ فالتحديث الأول أوقف التايمر الخاص به فقط ولكنه لم يتدخل في تايمرات النماذج التقليدية ( Timer Interval ) كاستخدامك لها في الـ ( Hot Folders ) ، مما استمر في مقاطعتك كمطور عند كتابتك للأكواد داخل المحرر . ولذلك ، ولحل هذه المعضلة بشكل جذري وجعل الفكرة ناجحة 100% ، قمت بتوسيع مهام حدث الويندوز ForegroundChangedProc . الفكرة الآن أنه وبمجرد مرور تركيز الويندوز إلى نافذة محرر الأكواد VBA ، سيقوم الكود بمسح جميع النماذج المفتوحة بلحظة واحدةً ، وبالتالي يحفظ قيم التايمر لها - عند وجود الحدث فقط - في ذاكرة مؤقتة ، ويجعل التايمر = 0 . وعند إغلاقك المحرر ، سيعيد الاستئناف بدقة لكل نموذج بناءً على ما تم حفظه في الذاكرة . وقد تم الاعتماد على خصيصة hWnd كمعرف فريد للنماذج بدلاً من اسمها تفادياً لأي خطأ ( في حال كنت تستدعي أكثر من نسخة لنفس الحدث ) 😅 . سنقوم بالإعلان عن متغير ( الذاكرة المؤقتة ) الذي ستعيش وتموت مع فتح وإغلاق محرر الأكواد VBA ، كالآتي :- Private colPausedForms As Collection الإضافة الثانية ( عملية الإيقاف والفكشنة عند فتح VBA ) . وتكون في الجزء الأول من دالة ForegroundChangedProc داخل شرط If IsVBEOpen() Then ، وهي المسؤولة عن حصر النماذج المفتوحة لدالة الصيد لتقوم بإيقافها وتتبع النماذج الفرعية داخلها :- Set colPausedForms = New Collection Dim frmMain As Object For Each frmMain In Forms PauseAllTimers frmMain Next frmMain الإضافة الثالثة ، وتكون في الجزء الثاني Else عند إغلاق الـمحرر ، وهي المسؤولة عن إعادة الروح للتايمرات وقيمها الأصلية كما كانت عليه :- If Not colPausedForms Is Nothing Then Dim frmMain2 As Object For Each frmMain2 In Forms ResumeAllTimers frmMain2 Next frmMain2 Set colPausedForms = Nothing End If أما الإضافة الرابعة والأخيرة 😅 ( دالتين صغيرتين بمثابة محركات البحث المتداخل ) ، لكتابة وحفظ البصمات 😁 :- Private Sub PauseAllTimers(frm As Object) If frm.TimerInterval > 0 Then On Error Resume Next colPausedForms.Add frm.TimerInterval, CStr(frm.Hwnd) frm.TimerInterval = 0 On Error GoTo 0 End If Dim ctl As Object On Error Resume Next For Each ctl In frm.Controls If ctl.ControlType = 112 Then If Not ctl.Form Is Nothing Then PauseAllTimers ctl.Form End If Next ctl On Error GoTo 0 End Sub Private Sub ResumeAllTimers(frm As Object) On Error Resume Next Dim savedInterval As Long: savedInterval = 0 savedInterval = colPausedForms(CStr(frm.Hwnd)) If savedInterval > 0 Then frm.TimerInterval = savedInterval Dim ctl As Object For Each ctl In frm.Controls If ctl.ControlType = 112 Then If Not ctl.Form Is Nothing Then ResumeAllTimers ctl.Form End If Next ctl On Error GoTo 0 End Sub الآن الكود بحلته الجديدة وملفه الجديد تالياً ( فضلاً لا أمراً ، افتح النموذج Frm_WithTimerInterval ) وضع به ما شئت من نماذج فرعية بداخل بعضها البعض ذات تايمرات مستمرة ! ثم جرب الدخول إلى المحرر Time With No TimerInterval.accdb