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

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

تفضل سامي.mdb

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي المرفق التالي يوزر فورم التقويم.xlsm

ما شاء الله زادك الله من فضله وبارك الله في عملك وهذا هدية مني لكم قمت بعمله ولم أنجز آخر شيت فيه لعدم حاجتي ولاستغنائي ببرنامج aSc TimeTables وبالتوفيق للجميع توزيع الحصص + الجدول.xlsm

السلام عليكم 🙂 الطريقة الوحيدة التي اعرفها ، هي عمل صورة ببرنامج خارجي ، وتدير الصورة بالزاوية التي تريدها ، ثم تلصقها في التقرير

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

التغيير سيكون في macro1 اجعله هكدا Public gtxtCalTarget As Variant Public Function LogError(lngErr As Long, strDescrip As String, strProc As String, _ Optional bShowUser As Boolean = True, Optional varParam As Variant) If bShowUser Then MsgBox "Error " & lngErr & ": " & strDescrip, vbExclamation, strProc End If End Function Public Function CalendarFor2(txt As Variant) On Error GoTo Err_Handler gtxtCalTarget = TextBox1 GalendarForm.Show Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & Err.Number & " - " & Err.Description, vbExclamation, "CalendarFor()" Resume Exit_Handler End Function وبعد اظافة الصورة مثلا Private Sub Image1_click() Call CalendarFor2(Me.TextBox1) End Sub اليك المرفق بعد اظافة تقويم جديد يمكنك اختيار ما يناسيك يوزر فورم 2 التقويم.xlsm

تفضل اخي تم اصلاح بعض الاخطاء في الاكواد سبب تهنيج الملف هو كود اظهار الساعة على اليوزرفورم قد تم استبداله بطريقة اخرى 1) تم تفعيل اكواد يوزرفورم 3 كما طلبت من قبل بطريقتين مختلفتين يمكنك اختيار ما يناسبك. 2) تم تعديل اكواد يوزرفورم 1 لتتماشى مع طريقة اشتغال الملف 3) تم استبدال معادلة ادراج تاريخ اليوم في عمود A بالكود التالي تفاديا لاظهار رسالة (Circular reference) Private Sub Worksheet_Change(ByVal TaFet As Range) Dim myRng As Range, F As Range, Col As Integer, lr As Long Set myRng = Intersect(Application.ActiveSheet.Range("B3:B2000"), TaFet) 'Column("A") Col = -1 If Not myRng Is Nothing Then For Each F In myRng If Not VBA.IsEmpty(F.Value) Then F.Offset(0, Col).Value = Now F.Offset(0, Col).NumberFormat = "dd-mm-yyyy" Else F.Offset(0, Col).ClearContents End If Next End If End Sub اكواد يوزرفورم 3 Dim F, K, WS_Data(), LigneN_Row Private Sub UserForm_Initialize() Set F = Sheet5 'Worksheets("الدخول") Set K = F.Range("A3:V" & F.[A65000].End(xlUp).Row) WS_Data = K.Value Set Réf = CreateObject("Scripting.Dictionary") a = F.Range("j3:j" & F.[j65000].End(xlUp).Row) For I = LBound(a) To UBound(a) If a(I, 1) <> Empty Then Réf(a(I, 1)) = Empty Next I WS2 = Réf.keys Me.ComboBox1.List = WS2 vidange_Click Me.TextBox1.SetFocus ComboBox1 = "*" Me.N_Row.Visible = False End Sub '''''''''''''''''''''''''''''' Private Sub ListBox1_Click() Me.TextBox1.Value = Me.ListBox1.Column(0) Me.ListBox1.Visible = False For I = 1 To UBound(WS_Data) If WS_Data(I, 10) = Me.TextBox1.Text Then N_linge = I Me.N_Row = N_linge + K.Row - 1 End If Next I Me.TextBox2.Text = WS_Data(N_linge, 10) ''''''''''''''' ' جلب التاريخ والساعة 'Me.TextBox3.Text = WS_Data(N_linge, 1) 'جلب التاريخ فقط Me.TextBox3.Text = Format(CDate(WS_Data(N_linge, 1)), "MM/DD/YYYY") '''''''''''''' Me.TextBox4.Text = WS_Data(N_linge, 6) Me.TextBox5.Text = WS_Data(N_linge, 7) Me.TextBox6.Text = WS_Data(N_linge, 9) Me.TextBox7.Text = WS_Data(N_linge, 2) Me.ComboBox1 = "*" Me.TextBox1 = "" End Sub '''''''''''''''''''''''''''' Private Sub TextBox1_Change() If Me.TextBox1.Text = "" Then Me.ListBox1.Visible = False Else Me.ListBox1.Visible = True Me.ListBox1.Clear '------------------------------ Dim K Set w = Sheet5 K = w.Cells(Rows.Count, 10).End(xlUp).Row l = 0 For Each c In Range("j3:j" & K) If c Like TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(l, 0) = Cells(c.Row, 10).Value l = l + 1 End If Next c End If Me.ComboBox1 = "*" End Sub Private Sub vidange_Click() For I = 1 To 7 Controls("textbox" & I).Text = Empty Next I Me.ComboBox1 = "*" End Sub Private Sub TextBox1_DblClick(ByVal cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" Me.ComboBox1 = "*" End If End Sub ''''''''''''''''''''''''''' Private Sub ComboBox1_click() For I = 1 To UBound(WS_Data) If WS_Data(I, 10) = Me.ComboBox1.Text Then N_linge = I Me.N_Row = N_linge + K.Row - 1 End If Next I Me.TextBox2.Text = WS_Data(N_linge, 10) ''''''''''''''' ' جلب التاريخ والساعة 'Me.TextBox3.Text = WS_Data(N_linge, 1) 'جلب التاريخ فقط Me.TextBox3.Text = Format(CDate(WS_Data(N_linge, 1)), "MM/DD/YYYY") '''''''''''''' Me.TextBox4.Text = WS_Data(N_linge, 6) Me.TextBox5.Text = WS_Data(N_linge, 7) Me.TextBox6.Text = WS_Data(N_linge, 9) Me.TextBox7.Text = WS_Data(N_linge, 2) Me.TextBox1.Text = Empty End Sub في انتظار ان توافينا بالنتيجة بعد التجربة بالتوفيق مخزون V3.xlsm

لتفعيل التاريخ الهجري من الاعدادات

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

الأخ أبو عاصم المصري، جزاك الله خيراً على الكود. الأخ مصطفى شاهين، فضلاً، انسخ الكود التالي كاملاً: Sub TrtebShar() 'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط ' On Error Resume Next If Selection.Information(wdWithInTable) = True Then 'تحديد العمود الثالث Selection.Tables(1).Columns(3).Select End If If Len(Selection.Text) = 1 Then MsgBox "من فضلك ظلل عمود الشطر الثاني الذي فيه القافية" Exit Sub End If Selection.Font.Color = 10498160 Selection.MoveLeft Unit:=wdCharacter, Count:=1 For i = 1 To 100000 Selection.EndKey Unit:=wdLine Selection.Find.ClearFormatting Selection.Find.Font.Color = 10498160 Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^$" .Replacement.Text = "" .Forward = False .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend Selection.Copy Selection.SelectRow Selection.Font.Color = wdColorAutomatic Selection.HomeKey Unit:=wdLine Selection.PasteAndFormat (wdPasteDefault) Selection.HomeKey Unit:=wdLine, Extend:=wdExtend If Selection.Font.Underline = wdUnderlineNone Then Selection.Font.Underline = wdUnderlineSingle Else Selection.Font.Underline = wdUnderlineNone End If Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "[ًٌٍَُِّْ]" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection = StrReverse(Selection) Selection.HomeKey Unit:=wdLine Selection.MoveDown Unit:=wdLine, Count:=1 Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineNone .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^$" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Selection.MoveLeft Unit:=wdCharacter, Count:=1 If Selection.Find.Found = False Then Exit For End If Next i Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = " [اويى]" .Replacement.Text = " " .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = True .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Sort ExcludeHeader:=False, FieldNumber:="عمود 1", SortFieldType _ :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, FieldNumber2 _ :="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _ wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _ wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _ wdSortSeparateByCommas, SortColumn:=False, CaseSensitive:=False, _ LanguageID:=wdArabic, SubFieldNumber:="فقرات", SubFieldNumber2:="فقرات", _ SubFieldNumber3:="فقرات" Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _ IgnoreDiacritics:=False, IgnoreHe:=False Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Selection.HomeKey Unit:=wdStory Beep MsgBox "تم ترتيب الشعر بنجاح" End Sub

احسنت يحفظك الرحمن الرحيم

السلام عليكم عمل فعلا ممتاز ... ومجهود رائع وكنا نطمع ان يكون بدون حماية ... حتى نستفيد ونطوعه ليتناسب مع مدارسنا كلٌ في بلده حتى تعم الاستفادة على الجميع . جعله الله في ميزان حسناتك،،،

بارك الله فيك استاذنا الكريم وجزاك الله خير الثواب

ممكن استخدامه في المدارس المصرية

حياك الله أستاذ أنا كانت حاجتي التحويل من الرقم الطويل إلى هيكس. وكنت قد صممت نفس الدالتين وأعتقد كان في منتدى الاكسل ولكن من الصعب أن أبحث عنهما، فأنا لا أحتفظ بأعمالي. عموما وجدت في النت بديلا عن دوالي: '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 وشكرا لأساتذة تشريفهم موضوعي.

سلمت يمناك أبو أحمد 🙂 استوقفتني هذه الجملة وقد مررت سابقا بموقف مشابه ، والآن مع وجود الذكاء الاصطناعي سألته يعطيني دالتين للتحويل بين أكواد ال RGB وال Hex فما قصر وأعطاني التالي ( بدون تجربة ) 🙂 : '=================== (To convert RGB to Hex:) Function RGBToHex(ByVal red As Integer, ByVal green As Integer, ByVal blue As Integer) As String RGBToHex = "#" & Right("0" & Hex(red), 2) & Right("0" & Hex(green), 2) & Right("0" & Hex(blue), 2) End Function '=================== (To convert Hex to RGB:) Function HexToRGB(ByVal hexCode As String) As Variant Dim red As Integer, green As Integer, blue As Integer If Left(hexCode, 1) = "#" Then hexCode = Right(hexCode, Len(hexCode) - 1) End If red = Val("&H" & Mid(hexCode, 1, 2)) green = Val("&H" & Mid(hexCode, 3, 2)) blue = Val("&H" & Mid(hexCode, 5, 2)) HexToRGB = Array(red, green, blue) End Function '=================== (Here's an example of how you can use these functions:) Sub TestColorConversion() Dim red As Integer, green As Integer, blue As Integer Dim hexCode As String Dim rgbResult As Variant ' Convert RGB to Hex red = 255 green = 0 blue = 128 hexCode = RGBToHex(red, green, blue) Debug.Print "Hex Code: " & hexCode ' Convert Hex to RGB hexCode = "#00FF00" rgbResult = HexToRGB(hexCode) red = rgbResult(0) green = rgbResult(1) blue = rgbResult(2) Debug.Print "RGB: (" & red & ", " & green & ", " & blue & ")" End Sub

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