Foksh

تفضل اخي @2saad هذا استعلام يحصي لك الأعداد التي طلبتها ، افتح النموذج Form1 SELECT Sum(IIf([Stuelnoa]=1,1,0)) AS Male_Count, Sum(IIf([Stuelnoa]=2,1,0)) AS Female_Count, Sum(IIf([Stuelnoa]=1 And [Stueldina]=2,1,0)) AS Christian_Male_Count, Sum(IIf([Stuelnoa]=2 And [Stueldina]=4,1,0)) AS Christian_Female_Count, Sum(IIf([Stuelnoa]=1 And [Stueldina]=1,1,0)) AS Muslim_Male_Count, Sum(IIf([Stuelnoa]=2 And [Stueldina]=3,1,0)) AS Muslim_Female_Count, Sum(IIf([Stuelnoa]=1 And [Stuelqid]=1,1,0)) AS New_Male_Count, Sum(IIf([Stuelnoa]=2 And [Stuelqid]=1,1,0)) AS New_Female_Count, Sum(IIf([Stuelnoa]=1 And [Stuelqid]=2,1,0)) AS Passed_Male_Count, Sum(IIf([Stuelnoa]=2 And [Stuelqid]=2,1,0)) AS Passed_Female_Count FROM Tastudent; New Microsoft3.accdb وأخبرني بالنتيجة 😊

😉 اقصد هذا السطر يا صديقي hMenu = GetSystemMenu(hwnd, 1&)

عمل جيد أخي @طير البحر ودعماً لمحاولتك ، هذا الجزء الخاص بزر RestoreDown Sub DisableRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M And Not WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub Sub RestoreRestoreDownButton() Dim hwnd As Long Dim M As Long hwnd = Application.hWndAccessApp M = GetWindowLong(hwnd, GWL_STYLE) M = M Or WS_MAXIMIZEBOX Call SetWindowLong(hwnd, GWL_STYLE, M) End Sub بعد إذنك لاحظت وجود خطأ في الجزء المسؤول عن أعادة تفعيل زر اغلاق الآكسيس :- أرجو التعديل من هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 0&) If hMenu Then ' DeleteMenu hMenu, SC_CLOSE, MF_BYCOMMAND 'Disable the Close button ááÇáÛÇÁ DrawMenuBar (hwnd) 'Repaint the MenuBar ááÊÔÛíá End If End Sub إلى هذا الجزء Sub enableCloseButtonfunction() Dim hwnd As Long Const SC_CLOSE = &HF060 Const MF_BYCOMMAND = &H0 hwnd = Application.hWndAccessApp Dim hMenu As Long hMenu = GetSystemMenu(hwnd, 1&) If hMenu Then DrawMenuBar (hwnd) End If End Sub

أخي @سيد رجب ، في الواقع بعد المتابعة وتحميل المرفقات لم أفهم المطلوب أو الهدف 😥 نرجو منك التوضيح !!!

استكمالاً لما سبق 👆 :- سنبدأ اليوم ببدء تصميم الجداول :- الجدول الأول جدول Country الخاص بالدول التي سيشملها البرنامج لحساب أوقات الصلاة . الجدول الثاني جدول City الخاص بالمدن المتفرعة لكل دولة في الجدول السابق . الجدول الثالث جدول Curcity الخاص بإعدادات المدينة الحالية التي سيتم عرض أوقات الصلاة لها . ( إختصار Current City ) . الجدول الرابع جدول PrayerCalculation الخاص بطريقة الحساب والمذاهب .... الخ . المرفق في المشاركة التالية 👇 يتبع ... 👈

مجرد سؤال أخي @2saad ، لو كان الاسم " عبد ربه" 😅 ، فما الحل ؟

تفضل أخي @waheidi2005 ، هذه محاولتي المتواضعة New Microsoft Access Database.accdb

تم تعديل الرابط في المشاركة السابقة

تم العمل على زري التنقل ( BtPrev و BtNext ) ولكني اعتقد انك تريد الفكرة على الرزنامة التي على اليسار ، هل هذا صحيح ؟؟.؟؟

أخي @عبد اللطيف سلوم ، هل هذا ما تريده ؟ فلل السعودية.accdb

استكمالاً لما سبق 👆 :- بطريقة بسيطة سيتم الاعتماد على حساب الجيب العكسي للزوايا باستخدام دالة الرمز الجيبي العكسي (Arcsine)، والتي يُرمز لها بـ ASin . تُستخدم الدالة ASin في الرياضيات لحساب الزاوية التي تمثلها الجيب العكسي لنسبة محددة من الجانب المقابل لزاوية مثلث، عندما يُعرف طول الضلع المقابل لهذه الزاوية . ويتمثل ذلك في المعادلة الرياضية . صورة تعبيرية وبناءً على هذه المعادلة سيتم احتساب أوقات الصلاة باستخدام معادلات فلكية و جيوغرافية ، ومن ثم سنعيد القيمة الراجعة بتنسيق معين بشكل وقت . حسب المديول التالي ، والذي يعتبر عامود المشروع وقوامه وأساسه :- Option Compare Database Const PI As Double = 3.14159265358979 Function ASin(Value As Double) As Double If Abs(Value) <> 1 Then ASin = Atn(Value / Sqr(1 - Value * Value)) Else ASin = 1.5707963267949 * Sgn(Value) End If End Function Public Function ACos(ByVal nValue As Double, Optional fRadians As Boolean = True) As Double ACos = -Atn(nValue / Sqr(1 - nValue * nValue)) + PI / 2 If fRadians = False Then ACos = ACos * (PI / 180) End Function Function gettimes(lag As Double, lat As Double, tzon As Double, stime As String, method As Integer, Optional dylt As Integer = 0, Optional strdate As Date) As Date ' تعريف المتغيرات المستخدمة Dim D, L, m, lambda, alpha, noon, alt, UTNoon, localNoon, st, Dec, ar, obl As Double ' حساب تاريخ اليوم D = (367 * Year(strdate)) - Int(((Year(strdate) + Int((Month(strdate) + 9) / 12)) * 7) / 4) + Int(275 * Month(strdate) / 9) + Day(strdate) - 730531.5 ' حساب زاوية الشمس والشروق والغروب L = 280.461 + 0.9856474 * D L = L - (360 * Int(L / 360)) m = 357.528 + 0.9856003 * D m = m - (360 * Int(m / 360)) lambda = L + 1.915 * Sin(m * PI / 180) + 0.02 * Sin(2 * m * PI / 180) obl = 23.439 - 0.0000004 * D ' حساب موضع الشمس وزاوية الشروق والغروب alpha = Atn(Cos(obl * PI / 180) * Tan(lambda * PI / 180)) * 180 / PI alpha = alpha - (360 * Int(alpha / 360)) alpha = alpha + 90 * (Fix(lambda / 90) - Fix(alpha / 90)) st = 100.46 + 0.985647352 * D st = st - (360 * Int(st / 360)) Dec = ASin(Sin(obl * PI / 180) * Sin(lambda * PI / 180)) * 180 / PI noon = alpha - st noon = noon - (360 * Int(noon / 360)) UTNoon = noon - lag localNoon = (UTNoon / 15) + tzon + dylt ' حساب أوقات الصلاة Select Case stime Case Is = "Fajr" ' حساب وقت الفجر alt = DLookup("FajrDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI fajr = localNoon - ar / 15 gettimes = Format(fajr / 24, "hh:nn:ss") Case Is = "Shrok" ' حساب وقت الشروق alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI shrouk = localNoon - ar / 15 gettimes = Format(shrouk / 24, "hh:nn:ss") Case Is = "Zohr" ' حساب وقت الظهر gettimes = Format(localNoon / 24, "hh:nn:ss") Case Is = "Asr1" ' حساب وقت العصر (الطريقة الأولى) alt = 90 - Atn(1 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Asr2" ' حساب وقت العصر (الطريقة الثانية) alt = 90 - Atn(2 + Tan(Abs(lat - Dec) * PI / 180)) * 180 / PI ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI asr = localNoon + ar / 15 gettimes = Format(asr / 24, "hh:nn:ss") Case Is = "Maghrib" ' حساب وقت المغرب alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 gettimes = Format(maghrib / 24, "hh:nn:ss") Case Is = "Eshaa" ' حساب وقت العشاء If method = 4 Then alt = -1 ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI maghrib = localNoon + ar / 15 If Month(CStr(Date)) = 9 Then gettimes = Format((maghrib + 2) / 24, "hh:nn:ss") Else gettimes = Format((maghrib + 1.5) / 24, "hh:nn:ss") End If Else alt = DLookup("IshaDegree", "PrayerCalculation", "MethodType=" & method & "") ar = ACos((Sin(alt * PI / 180) - Sin(Dec * PI / 180) * Sin(lat * PI / 180)) / (Cos(Dec * PI / 180) * Cos(lat * PI / 180))) * 180 / PI eshaa = localNoon + ar / 15 gettimes = Format(eshaa / 24, "hh:nn:ss") End If End Select End Function يتبع ... 👈

أخي @Bshar جزاك الله خيراً على هذه الثقة 🥰 . اتمنى أن أكون قد وصلت الى حل مناسب ، انظر ماذا فعلت للوصول لطلبك :- 1. قمت بالتعديل على الاستعلام والذي هو مصدر سجلات للنموذج الفرعي ليصبح فقط لفلترة الاسم . بهذا الشكل SQL :- SELECT doc.name, tape.ID, tape.[code-work], tape.[t-namber], tape.type, tape.lincec, tape.color FROM doc INNER JOIN tape ON doc.ID = tape.[code-work] WHERE (((doc.name) Like "*" & [Forms]![add-tab]![xxf] & "*")); 2. انشأت مربع نص وأسميته Foksh 😁 ، وجعلت قيمته :- Me.Foksh = Foksh & "," & Me.xxc ' هو كومبوبوكس الألوان XXC حيث 3. انشأت دالة لتطبيق الفلترة :- Private Sub ApplyFilter() Dim filterCriteria As String Dim selectedValues() As String Dim i As Integer selectedValues = Split(Me.Foksh, ",") For i = LBound(selectedValues) To UBound(selectedValues) If selectedValues(i) <> "" Then filterCriteria = filterCriteria & "[tape].[color] = '" & Trim(selectedValues(i)) & "' OR " End If Next i If filterCriteria <> "" Then filterCriteria = Left(filterCriteria, Len(filterCriteria) - 4) End If Me.tape5.Form.Filter = filterCriteria Me.tape5.Form.FilterOn = True End Sub 4. في حدث بعد التحديث للكومبوبوكس XXC سيتم نقل القيم الى مربع النص Foksh والفصل بين القيم عند تغييرها بالفاصلة "," :- Me.Foksh = Foksh & "," & Me.xxc ApplyFilter Me.tape5.Requery وفي النهاية هذا هو الناتج tesst.accdb

جاري العمل ، تقريباً توصلت لطريقة آمنة 😁

أخي الكريم @سيد رجب ، يبدو أنك نسيت ارفاق قاعدة بيانات الجداول لتجربة مشروعك

تفضل ، استبدل هذا الكود للنموذج :- Private Sub Btn_Copy_Click() If Text1.Value <> "" And Text2.Value <> "" Then Dim sourcePath As String Dim destPath As String sourcePath = Text1.Value destPath = Text2.Value If Dir(sourcePath, vbDirectory) <> "" Then If Dir(destPath, vbDirectory) <> "" Then CopyFiles sourcePath, destPath DeleteFilesInFolder sourcePath MsgBox "تم نقل الملفات بنجاح", vbInformation Else MsgBox "المجلد الهدف غير موجود", vbExclamation End If Else MsgBox "المجلد المصدر غير موجود", vbExclamation End If Else MsgBox "يرجى تحديد مسار لكل من المجلد المصدر والمجلد الهدف", vbExclamation End If End Sub Private Sub CopyFiles(ByVal sourcePath As String, ByVal destPath As String) Dim fso As FileSystemObject Set fso = New FileSystemObject Dim sourceFolder As folder Set sourceFolder = fso.GetFolder(sourcePath) Dim destFolder As folder Set destFolder = fso.GetFolder(destPath) Dim file As file For Each file In sourceFolder.Files fso.CopyFile file.Path, destFolder.Path & "\" & file.Name Next file End Sub Private Sub DeleteFilesInFolder(ByVal folderPath As String) Dim fso As FileSystemObject Set fso = New FileSystemObject Dim folder As folder Set folder = fso.GetFolder(folderPath) Dim file As file For Each file In folder.Files fso.DeleteFile file.Path Next file End Sub Private Function IsFolderEmpty(ByVal folderPath As String) As Boolean Dim fso As FileSystemObject Set fso = New FileSystemObject Dim folderContents As Files Set folderContents = fso.GetFolder(folderPath).Files IsFolderEmpty = (folderContents.Count = 0) End Function Private Sub Btn1_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text1.Value = selectedFolder End If End Sub Private Sub Btn2_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text2.Value = selectedFolder End If End Sub Copy Files.accdb

جرب هذا المرفق أخي @imad2024 Copy Files.accdb تم انشاء مربعي النص ( Text1 , Text2 ) لتحديد المسارات ( المصدر والهدف ) وتم انشاء الزرين ( Btn1 , Btn2 ) بجانب كل مربع نص لتحديد مسار المجلدات . وتم انشاء زر لتنفيذ عملية النسخ من - إلى وتم انشاء دالة مستقلة للنسخ CopyFolder . Private Sub Btn_Copy_Click() If Text1.Value <> "" And Text2.Value <> "" Then Dim sourcePath As String Dim destPath As String sourcePath = Text1.Value destPath = Text2.Value If Dir(sourcePath, vbDirectory) <> "" Then If Dir(destPath, vbDirectory) <> "" Then CopyFolder sourcePath, destPath MsgBox "تم نقل الملفات بنجاح", vbInformation Else MsgBox "المجلد الهدف غير موجود", vbExclamation End If Else MsgBox "المجلد المصدر غير موجود", vbExclamation End If Else MsgBox "يرجى تحديد مسار لكل من المجلد المصدر والمجلد الهدف", vbExclamation End If End Sub Private Sub Btn1_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text1.Value = selectedFolder End If End Sub Private Sub Btn2_Click() Dim dialog As FileDialog Dim selectedFolder As Variant Set dialog = Application.FileDialog(msoFileDialogFolderPicker) If dialog.Show = -1 Then selectedFolder = dialog.SelectedItems(1) Text2.Value = selectedFolder End If End Sub Private Sub CopyFolder(ByVal sourcePath As String, ByVal destPath As String) Dim fso As FileSystemObject Set fso = New FileSystemObject Dim sourceFolder As Folder Set sourceFolder = fso.GetFolder(sourcePath) Dim destFolder As Folder Set destFolder = fso.GetFolder(destPath) fso.CopyFolder sourceFolder.Path, destFolder.Path End Sub

أخواني واساتذتي ، ما زال العمل على المشروع قيد التطوير 🤗

لا اعتقد ذلك .

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) كنت قد بحثت في المنتدى 🔍 (هنا) عن برامج لعرض مواقيت الصلاة ، وقد وجدت الكثير من المواضيع الجميلة والأفكار النيرة في المنتدى لأساتذة وأخوة بذلوا جهداً لا يوصف في مشاركاتهم بهذا الموضوع ، وإلى حد ما أكثرهم قرباً لضبط الأوقات كانت هذه المشاركة . اليوم الفكرة مختلفة قليلاً في هذا المشروع المتواضع والذي لا يحتوي تعقيدات يصعب قراءتها أو التعامل معها في الأكواد . حيث اعتمدت وتوجهت إلى البساطة من حيث عند النقل والدمج ( إلى / في ) أي مشروع . الآن شرح بسيط لبعض تفاصيل المشروع التي سيتم الإعتماد عليها :- سي سيتم الإعتماد على خطوط الطول والعرض بعد إجراء بعض التعديلات على طريقة احتساب الأوقات . وقد تمت المقارنة مع موقع ( مواقيت الصلاة ) للوصول إلى أقل فارق - إن وُجِد - في المواقيت . سيتم الإعتماد على تقويم أم القرى في أحدى مشاركات أستاذنا @ابوخليل . سيتم اعتماد إظهار الوقت المتبقي لكل موعد صلاة في الشاشة الرئيسية أو المصغرة ( ستضاف لاحقاً ) . سيتم منح الحرية للمستخدم بنوع التذكير لوقت الصلاة ( إشعار برسالة تنبيه داخل البرنامج ، إشعار فوق شريط Taskbar ) . سيتم أيضاً منح الحرية للمستخدم باختيار صوت التنبيه ( أذان كامل ، تكبير ، .... إلخ ) . المزيد من الأمور ستأتي لاحقاً تباعاً في تطويرات وتحديثات جديدة إن شاء الله . صورة لواجهة البرنامج حالياً ، والذي أسميته في الوقت الحالي " صلوات " 🤗 ، ما لم يتم اختيار اسم آخر تم التعديل بتاريخ 01/06/2024 وذلك لاضافة المرفق النهائى Salatak.zip

تفضل أخي @الباحث الباحث Scanner.accdb

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

اخي @2saad لاحظ انك غير مهتم بحل المشكلة رغم متابعة عدد كبير من الأساتذة في الردود وتعدد الحلول. وما زلت تسأل دون إرفاق ملفك الذي تعمل عليه . شكراً بالنيابة عن المتابعة.