البحث في الموقع

تقومان بفحص تقويم الـ 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

ملاحظاتي: - أتعبني تحويل رقم اللون الطويل إلى هيكس 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