AbuuAhmed

مجهود تشكر عليه عزيزي، عملت شيء مشابه للفكرة قديما للشركات التي عملت بها بس لا أتذكر الطريقة ولا عندي نسخ من تلك البرامج. ما جربت الكود، ولكن لفت نظري أنك تقوم بعد الحصول على وقت الخادم/السيرفر بعمليات حسابية لمعرفة الفرق. وملاحظتي "إن كنت فهمت صح" لماذا لا تعتمد تاريخ الخادم مباشرة بعيدا عن المقارنات وحساب الفرق؟

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

وهذا لن يغني عن استخدام دوال التحويل. فمن تقويمه في قاعدة البيانات ميلادي فهو في حاجة لدالة التحويل إلى هجري عند الرغبة. ومن تقويمه في قاعدة البيانات هجري فهو في حاجة لدالة التحويل إلى ميلادي عند الرغبة.

تقومان بفحص تقويم الـ vba ونوع المدخل، فهي تساعد المستخدم كثيرا وتجنبه الأخطاء إن شاء الله. عملت تجاربي عليها، ويمكنكم اجراء المزيد من التجارب. Option Compare Database Option Explicit Function Greg2Hijri(GregDate As Variant, _ Optional dFormat As String = "yyyy/mm/dd") As Variant Dim CurCal As VbCalendar On Error Resume Next CurCal = Calendar Greg2Hijri = Null '"WrongInput" If Calendar = vbCalGreg And (VarType(GregDate) = vbDate Or _ VarType(GregDate) = vbLong) Then Calendar = vbCalHijri Greg2Hijri = Format(GregDate, dFormat) ElseIf VarType(GregDate) = vbString Then Calendar = vbCalGreg If IsDate(GregDate) Then Greg2Hijri = CDate(GregDate) End If End If Calendar = CurCal End Function '------------------------- Function Hijri2Greg(HijriDate As Variant, _ Optional dFormat As String = "yyyy/mm/dd") As Variant Dim CurCal As VbCalendar On Error Resume Next CurCal = Calendar Hijri2Greg = Null '"WrongInput" If Calendar = vbCalHijri And (VarType(HijriDate) = vbDate Or _ VarType(HijriDate) = vbLong) Then Calendar = vbCalGreg Hijri2Greg = Format(HijriDate, dFormat) ElseIf VarType(HijriDate) = vbString Then Calendar = vbCalHijri If IsDate(HijriDate) Then Hijri2Greg = CDate(HijriDate) End If End If Calendar = CurCal End Function '-------------------------------------------------------------------- Sub TestingDateConverting() Dim CurCal As VbCalendar CurCal = Calendar Debug.Print "Greg2Hijri" Calendar = vbCalGreg Debug.Print Greg2Hijri(Date, "yyyy-mmmm-dd") Debug.Print Greg2Hijri(CLng(Date), "yyyy mm dd") Debug.Print Greg2Hijri("06/07/2023") Debug.Print "-----------" Calendar = vbCalHijri Debug.Print Greg2Hijri(Date, "yyyy-mmmm-dd") Debug.Print Greg2Hijri(CLng(Date), "yyyy mm dd") Debug.Print Greg2Hijri("06/07/2023") Debug.Print "-------------------------------" Debug.Print "Hijri2Greg" Calendar = vbCalHijri Debug.Print Hijri2Greg(Date, "yyyy-mmmm-dd") Debug.Print Hijri2Greg(CLng(Date), "yyyy mm dd") Debug.Print Hijri2Greg("18/12/1444") Debug.Print "-----------" Calendar = vbCalGreg Debug.Print Hijri2Greg(Date, "yyyy-mmmm-dd") Debug.Print Hijri2Greg(CLng(Date), "yyyy mm dd") Debug.Print Hijri2Greg("18/12/1444") Debug.Print "-------------------------------" Calendar = CurCal End Sub

شكرا أستاذ، ما عليك زود

وجدت الحدث، وهذه أول مرة أجربه منذ أن دخلت عالم الأكسس 🙂 Private Sub Form_Error(DataErr As Integer, Response As Integer) If DataErr = 3200 Then Response = 0 MsgBox "لا يمكن حذف هذا الموظف قبل حذف إجازاته" End If End Sub DeleteParentRecord_02.accdb

شكرا، في أي حدث وضعت هذا الكود؟ هل يمكنك وضعه في مثالي ورفعه هنا؟

عن طريق النموذج استخدم زر حذف بدلا من محدد السجل. هذا اللي خطر في بالي الآن، يمكن الزملاء لديهم تجارب أفضل. DeleteParentRecord_01.accdb

لا تستطيع تغيير لون التظليل ولا الخط.

تشتتي زاد مع هذا الموضوع 😞 النسخ مرة أخرى بعد تصحيح الخطأ الأخير. RichText_Memo_07.accdb RichText_Query_07.accdb PlainText_Sel_07.accdb

بدل Right إلى Mid في هذا السطر: With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) ليصبح كالتالي: With Forms(Left(frmCtl, sPos - 1)).Controls(Mid(frmCtl, sPos + 1))

#If Vba7 Then Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hwnd As Long, rgb As Long) #Else Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" (ByVal hWnd As Long, rgb As Long) #End If Function DialogColor(rgb As Long) As Long Call ChooseColor(Application.hWndAccessApp, rgb) DialogColor = rgb End Function كلامك صحيح، تم التصحيح.

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

تم الوصول إلى جواب لسؤالي عن طريق هذا الرد: https://stackoverflow.com/questions/55523926/font-limitation-in-msaccess-richtext-edit-tool#:~:text=What you can do is to set the,11 in the format toolbar for regular text. وقد قمت بتصميم دالة لحل هذه المشكلة: Function RichTextFontSize(FontSize As Double) As Byte Dim fs As Byte If FontSize <= 8 Then fs = 1 ElseIf Between(FontSize, 9, 10) Then: fs = 2 ElseIf Between(FontSize, 11, 12) Then: fs = 3 ElseIf Between(FontSize, 13, 16) Then: fs = 4 ElseIf Between(FontSize, 17, 22) Then: fs = 5 ElseIf Between(FontSize, 23, 30) Then: fs = 6 Else: fs = 7 End If RichTextFontSize = fs End Function هذا آخرر إصدرا بعد حل باقي المشكلات العالقة: RichTextHighlight_04.accdb

تم إضافة التصفية واستخدام حدث عند التغيير يتبقى البحث عن تحويل حجم الخط بشكل علمي صحيح. RichTextHighlight_03.accdb

مثال 2 DateConverter_02.mdb

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

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

تم إضافة أزرار خصائص الخط وخلفية صندوق مفتاح البحث. RichTextHighlight_02.accdb

حياك الله أستاذ أنا كانت حاجتي التحويل من الرقم الطويل إلى هيكس. وكنت قد صممت نفس الدالتين وأعتقد كان في منتدى الاكسل ولكن من الصعب أن أبحث عنهما، فأنا لا أحتفظ بأعمالي. عموما وجدت في النت بديلا عن دوالي: 'Author : Mike Wolfe Function ConvertColorToRgb(ColorValue As Long) As String Dim Red As Long, Green As Long, Blue As Long Red = ColorValue Mod 256 Green = ((ColorValue - Red) / 256) Mod 256 Blue = ((ColorValue - Red - (Green * 256)) / 256 / 256) Mod 256 ConvertColorToRgb = "RGB(" & _ Red & ", " & _ Green & ", " & _ Blue & ")" End Function ومنها نستطيع استخدام الدالة التي جلبتها أنت RGBToHex وشكرا لأساتذة تشريفهم موضوعي.

ملاحظاتي: - أتعبني تحويل رقم اللون الطويل إلى هيكس Hex أرقام سداسية إن صح التعبير واضطررت لعمل دالة لمعالجة مخرجات الدالة الأصل. - لم أصل إلى نوع مقاس الخط لأتمكن من حويلة بشكل دقيق فاضطررت لاستخدام رقم تقريبي بتقسيمه على 3.5 . - استخدمت كل خصائص الخط في صندوق كلمة/نص البحث ما عدا اسم الخط. - حاليا تبديل خصائص الخط في صندوق البحث يدويا (في طور التصميم) ويمكنكم إضافة تعديله بواسط الأزرار والخيارات في طور التشغيل. - مسموح للجميع التطوير فيه مباشرة وبدون إذن. - الدالة مصممة ليستفاد منها في الاستعلامات وفي الجداول لحقول المذكرة. Option Compare Database Option Explicit Function myHex(Color As Long) As String Dim hexStr As String hexStr = Hex(Color) If Len(hexStr) = 6 Then hexStr = Right(hexStr, 2) & Mid(hexStr, 3, 2) & Left(hexStr, 2) Else hexStr = Left(Right(hexStr, 2) & Left(hexStr, Len(hexStr) - 2) & "000000", 6) End If myHex = "#" & hexStr End Function Function RichText(ByVal sText As Variant, frmCtl As String) As String Dim sWord As String Dim lStr As String Dim rStr As String Dim sPos As Integer Dim fSize As Double sPos = InStr(1, frmCtl, ",") With Forms(Left(frmCtl, sPos - 1)).Controls(Right(frmCtl, sPos + 1)) sText = PlainText(Nz(sText, "")) sWord = PlainText(Nz(.Value, "")) rStr = "</font>" lStr = "<font color=""" & myHex(.ForeColor) & """>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) 'sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) lStr = "<font style='BACKGROUND-COLOR:" & myHex(.BackColor) & "'>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) fSize = .FontSize / 3.5 'تحويل تقريبي lStr = "<font size=" & fSize & "pt>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) If .FontBold Then lStr = "<b>": rStr = "</b>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontItalic Then lStr = "<i>": rStr = "</i>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If If .FontUnderline Then lStr = "<u>": rStr = "</u>" sText = Replace(sText, sWord, lStr & sWord & rStr, 1) End If End With RichText = sText End Function RichTextHighlight_01.accdb

وهذه الدالة بعد تقليل أسطرها وتبديل التكرار باستخدام دالة replace Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(Replace(sText, lStr, "", 1), rStr, "") sText = Replace(sText, sWord, lStr & sWord & rStr, 1) sText = Replace(Replace(sText, rStr & " " & lStr, " ", 1), rStr & "" & lStr, "", 1) RichText = sText End Function

عزيزي أحيانا اللي جالسين في المدرجات يرون ما لا يراه اللاعبون. وأكيد مرت عليك أن تقوم بتعديل أكوادك أكثر من مرة وأحيانا تضحك من عملك وتتساءل كيف غفلت وارتكبت تلك الهفوات. على كل أرجو الانتباه أن أستخدم الدالة للاستعلام ولحقل مذكرة وهنا ستغير من رأيك السابق مع مزيد من التأمل. وهنا الكود الطويل القصير مع شرح مبسط لغير الخبراء: Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer 'للتخلص من القيمة null sText = Nz(sText, "") sWord = Nz(sWord, "") 'لتكرار استخدام عبارتي حصر اللون وضعناهما في متغيرين lStr = "<font color=red>" rStr = "</font>" 'لإزالة التنسيق القديم من حقل المذكرة sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) 'تكرار لتلوين جمعيع الكلمات في الحقل الواحد sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop 'لاحتصار النص وخصوصا لحقل المذكرة بإزالة تكرار عبارات الحصر للون sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function أما بالنسبة للاختصار فيمكن التالي: من سطرين إلى سطر لأزالة التنسيق القديم وهذ مطلوب لحقل مذكرة وغير مطلوب للاستعلام. ما تفضلت به بتبديل التكرار بدالة replace وسأقوم بتجربتها مع أني استخدمت وظيفتها بدلا منها واستخدمتها في الدالة 4 مرات. من سطرين إلى سطر لإزالة تكرار عبارات حصر اللون وهو مهم أكثر في حقل المذكرة لأننا نقوم بتخزين النص والتنسيق معا.

الأفكار تتدافع للاستفادة من الفكرة الجديدة، الآن الدلة تلون أكثر من كلمة في الحقل الواحد. الفكرة التالية هي زيادة خصائص الكلمة كنوع الخط ولون الخلفية وحجم الخط والخط المائل وخط أسفل الكلمة. ما أريده هو تمرير الأداة للدالة عند استخدام الاستعلام. هل أحد جرب هذه الحيثية؟ Function RichText(ByVal sText As Variant, ByVal sWord As Variant) As String Dim lStr As String Dim rStr As String Dim sPos As Integer sText = Nz(sText, "") sWord = Nz(sWord, "") lStr = "<font color=red>" rStr = "</font>" sText = Replace(sText, lStr, "", 1) sText = Replace(sText, rStr, "", 1) sPos = InStr(1, sText, sWord) Do While sPos > 0 sText = Left(sText, sPos - 1) & _ lStr & sWord & rStr & _ Mid(sText, sPos + Len(sWord)) sPos = InStr(sPos + Len(sWord & lStr), sText, sWord) Loop sText = Replace(sText, rStr & " " & lStr, " ", 1) sText = Replace(sText, rStr & "" & lStr, "", 1) RichText = sText End Function SearchSel_04.accdb

لم يأني في خلدي فكرة عمل الصندوق مع الاستعلام. فكرة جميلة جدا، مثال تعلمت منه الجديد المفيد اليوم. المثال بعد تطبيق الفكرة الجديدة. SearchSel_03.accdb