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

السلام عليكم ورحمة الله وبركاته ،، في طور تحسين الأداة الجديدة ( لم يعلن عنها بعد ) ، للتعامل مع الأكواد التي تعمل على 32 ولا تعمل على 64 ، ما زال العمل جاري على تحسين أداء الأداة ، بحيث من خلال النقاش المفتوح نأتي للوصول الى أفضل أداء ونتيجة . مرفق صورة توضيحية للوضع الحالي للأداة ، مع طرح مثال لكود قبل وبعد التحويل الناتج من الأداة . الكود الذي تمت التجربة عليه كمثال ( لا الحصر ) :- Option Compare Database Option Explicit Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As _ Any) As Long Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub النتيجة من الأداة بعد التحسينات والتعديلات :- 'Code converted to 64-bit compatibility By Foksh ( Officena.Net ) 'Generated on: 2025-05-23 15:22:26 'Tool version: Ver : 1.0 Option Compare Database Option Explicit #If VBA7 Then Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Long, lParam As Any) As Long #Else Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub باب النقاش مفتوح لأي تعليقات وتوضيحات وتحديثات للجميع .. الأداة حصرية وليس لها أي أساس في أي موقع أجنبي أو عربي ( فقط في أوفيسنا ) *ملاحظة :- الدعوة للنقاش لا تقتصر على من لديه خبرة في آكسيس فقط . أيضاً أخوتنا الأساتذة برتبة ( خبير ) الذين أشعر أنهم غير معنيين بالمشاركة بمواضيع أخوتهم الأساتذة في هذا المنتدى هم معنيين خصوصاً بالمشاركة وإبداء الرأي ، وأرجو ان لا تكون هذه العبارة في غير محلها 😎 . نحن نتكاتف هنا لنتشارك معرفتنا وعلمنا الذي علمنا إياه الله - ولا علم إلا علمه . لذا متأملاً منهم خصوصاً مشاركتنا أفكارهم .

هذا البرنامج هو لحساب المواريث والوصايا بالاكسل يمكن تشغيله بالنقال الذكى ..او الحاسوب نسخة 2024 اعداد الفرضى المهندس خالد الطاهر حدادة عنوان البريد الإلكتروني khaledhadada47@gmail.com ليبيا الفرائض_الربانية_بالجداول_الالكترونية_2024.xlsx

والرد من باب النكاش وبعيدا عن اى نقاش لان خلاص فاضل تكــه هذه الحسابات تستند إلى نمو الجنين الطبيعي خلال مراحل الحمل وفقا لدراسات طبية وملاحظات حول كيفية تطور الجنين في الرحم في كل أسبوع من أسابيع الحمل هذه الحسابات الدراسية طبعا انت يا فؤش أفندى لازم تصحى الوحش اللى جوايا يعنى الله يسامحك بقالى ساعه اكتب وصوابعى وجعتنى وانت عارف ليه طيب بعد البحث لو اردنا نتائج اكثر دقة وبالاستناد الى هذا الموقع المتخصص https://www.babycenter.com/pregnancy/your-body/growth-chart-fetal-length-and-weight-week-by-week_1290794 هيكون ده شكل الكود النهائى اللى قبل التكه علشان خلاص Option Compare Database Option Explicit ' ثابت لتوحيد تنسيق التاريخ باستخدام نمط ISO (YYYY-MM-DD) Private Const IsoDateFormat As String = "yyyy-mm-dd" ' تعريف Enum للثلث الحملي Public Enum EnmTrimester First = 1 Second = 2 Third = 3 End Enum ' ================================ ' دوال مساعدة ' ================================ ' دالة للاستيفاء الخطي مع حماية ضد القسمة على صفر Private Function LinearInterpolate(ByVal x As Double, ByVal x1 As Double, ByVal x2 As Double, ByVal y1 As Double, ByVal y2 As Double) As Double If x2 - x1 = 0 Then LinearInterpolate = y1 ' إرجاع y1 إذا كان الفاصل صفرًا Else LinearInterpolate = y1 + (y2 - y1) * (x - x1) / (x2 - x1) End If End Function ' دالة لتحويل الثلث الحملي إلى نص عربي Private Function TrimesterToString(ByVal trimester As EnmTrimester) As String Select Case trimester Case EnmTrimester.First: TrimesterToString = "الثلث الأول" Case EnmTrimester.Second: TrimesterToString = "الثلث الثاني" Case EnmTrimester.Third: TrimesterToString = "الثلث الثالث" End Select End Function ' دالة لحساب تاريخ الولادة المتوقع (EDD) Private Function GetEDD(ByVal LMP As Date, ByVal CycleLength As Integer, ByVal IsMultiplePregnancy As Boolean) As Date If IsMultiplePregnancy Then GetEDD = DateAdd("d", 266 + (CycleLength - 28), LMP) Else GetEDD = DateAdd("d", 280 + (CycleLength - 28), LMP) End If End Function ' دالة لحساب تاريخ التبويض Private Function GetOvulationDate(ByVal LMP As Date, ByVal CycleLength As Integer) As Date GetOvulationDate = DateAdd("d", CycleLength \ 2, LMP) End Function ' دالة لتحديد الثلث الحملي Private Function GetTrimester(ByVal Weeks As Long) As EnmTrimester Select Case Weeks Case 0 To 13: GetTrimester = EnmTrimester.First Case 14 To 26: GetTrimester = EnmTrimester.Second Case Else: GetTrimester = EnmTrimester.Third End Select End Function ' دوال تنسيق Private Function FormatDate(ByVal d As Date) As String FormatDate = Format(d, IsoDateFormat) End Function Private Function FormatWeeksDays(ByVal Weeks As Long, ByVal Days As Long) As String FormatWeeksDays = Weeks & " أسابيع و " & Days & " أيام" End Function Private Function FormatMonthsDays(ByVal Months As Double, ByVal Days As Long) As String FormatMonthsDays = Format(Months, "0") & " شهور و " & Days & " أيام" End Function Private Function FormatDays(ByVal Days As Long) As String FormatDays = Days & " أيام" End Function ' دالة لتوليد رسائل تحذير مخصصة Private Function GetWarningMessage(ByVal Context As String, ByVal Weeks As Long, ByVal trimester As EnmTrimester) As String Select Case Context Case "PostTerm" GetWarningMessage = "عمر الحمل تجاوز 42 أسبوعًا. يُنصح بالمتابعة الفورية مع أخصائي النساء والتوليد لتقييم الوضع واتخاذ القرار المناسب." Case "InvalidLMP" GetWarningMessage = "تاريخ آخر دورة شهرية يجب أن يكون قبل التاريخ الحالي. يرجى تصحيح الإدخال." Case "InvalidCycleLength" GetWarningMessage = "طول الدورة الشهرية يجب أن يكون بين 21 و35 يومًا. سيتم استخدام القيمة الافتراضية (28 يومًا)." Case "EarlyPregnancy" GetWarningMessage = "الحمل في مرحلة مبكرة جدًا (أقل من 4 أسابيع). يُنصح بزيارة الطبيب لتأكيد الحمل." Case "InvalidInput" GetWarningMessage = "المدخلات غير صالحة. يرجى التأكد من إدخال تاريخ وطول دورة شهرية صحيحين." Case Else GetWarningMessage = "يرجى مراجعة الطبيب لتقييم حالة الحمل في " & TrimesterToString(trimester) & "." End Select End Function ' دالة للتحقق من صحة المدخلات Private Function ValidateInputs(ByVal LMP As Variant, ByVal CycleLength As Variant, ByVal Today As Date) As String If IsNull(LMP) Or Not IsDate(LMP) Then ValidateInputs = "InvalidInput" ElseIf LMP > Today Then ValidateInputs = "InvalidLMP" ElseIf Not IsNumeric(CycleLength) Or CycleLength < 21 Or CycleLength > 35 Then ValidateInputs = "InvalidCycleLength" Else ValidateInputs = "" End If End Function ' ================================ ' دوال تقدير وزن وطول الجنين ' ================================ Public Function EstimatedWeight(ByVal Weeks As Integer, Optional ByVal IsMultiplePregnancy As Boolean = False) As Variant Dim WeeksArray, WeightArray WeeksArray = Array(4, 6, 8, 12, 16, 20, 24, 28, 32, 36, 40, 42) WeightArray = Array(1, 10, 20, 58, 190, 331, 660, 1176, 1900, 2800, 3619, 3800) If Weeks > 42 Then EstimatedWeight = Array(WeightArray(UBound(WeightArray)), True) Exit Function End If Dim i As Integer For i = 0 To UBound(WeeksArray) - 1 If Weeks >= WeeksArray(i) And Weeks <= WeeksArray(i + 1) Then Dim weight As Double weight = LinearInterpolate(Weeks, WeeksArray(i), WeeksArray(i + 1), WeightArray(i), WeightArray(i + 1)) If IsMultiplePregnancy Then weight = weight * 0.85 EstimatedWeight = Array(weight, False) Exit Function End If Next i If Weeks < WeeksArray(0) Then EstimatedWeight = Array(WeightArray(0), False) Else EstimatedWeight = Array(WeightArray(UBound(WeightArray)), False) End If End Function Public Function EstimatedLength(ByVal Weeks As Integer, Optional ByVal IsMultiplePregnancy As Boolean = False) As Variant Dim WeeksArray, LengthArray WeeksArray = Array(4, 6, 8, 12, 16, 20, 24, 28, 32, 36, 40, 42) LengthArray = Array(0.2, 0.8, 1.57, 5.4, 11.6, 25.7, 33, 38.6, 44, 48, 51, 52) If Weeks > 42 Then EstimatedLength = Array(LengthArray(UBound(LengthArray)), True) Exit Function End If Dim i As Integer For i = 0 To UBound(WeeksArray) - 1 If Weeks >= WeeksArray(i) And Weeks <= WeeksArray(i + 1) Then Dim length As Double length = LinearInterpolate(Weeks, WeeksArray(i), WeeksArray(i + 1), LengthArray(i), LengthArray(i + 1)) If IsMultiplePregnancy Then length = length * 0.85 EstimatedLength = Array(length, False) Exit Function End If Next i If Weeks < WeeksArray(0) Then EstimatedLength = Array(LengthArray(0), False) Else EstimatedLength = Array(LengthArray(UBound(LengthArray)), False) End If End Function ' ================================ ' دالة حساب شهر الحمل ' ================================ Public Function GetPregnancyMonth(ByVal Weeks As Long) As Variant Select Case Weeks Case 0 To 4: GetPregnancyMonth = Array(1, False) Case 5 To 8: GetPregnancyMonth = Array(2, False) Case 9 To 13: GetPregnancyMonth = Array(3, False) Case 14 To 17: GetPregnancyMonth = Array(4, False) Case 18 To 21: GetPregnancyMonth = Array(5, False) Case 22 To 26: GetPregnancyMonth = Array(6, False) Case 27 To 30: GetPregnancyMonth = Array(7, False) Case 31 To 35: GetPregnancyMonth = Array(8, False) Case 36 To 42: GetPregnancyMonth = Array(9, False) Case Else: GetPregnancyMonth = Array(9, True) End Select End Function ' ================================ ' دالة التوصيات الطبية ' ================================ Public Function GetMedicalCheckup(ByVal Weeks As Long) As String Select Case Weeks Case 4 To 5 GetMedicalCheckup = "زيارة مبكرة لتأكيد الحمل." Case 6 To 8 GetMedicalCheckup = "زيارة تأكيد الحمل وفحص مبكر بالموجات فوق الصوتية." Case 10 To 13 GetMedicalCheckup = "فحص الشفافية القفوية (NT Scan) وفحص الدم الأولي." Case 16 GetMedicalCheckup = "فحص الدم للكشف عن التشوهات الجينية (Triple/Quad Screen)." Case 20 GetMedicalCheckup = "فحص السونار التشريحي لتقييم نمو الجنين." Case 24 To 28 GetMedicalCheckup = "فحص السكري في الحمل (Glucose Tolerance Test)." Case 32 GetMedicalCheckup = "فحص نمو الجنين بالموجات فوق الصوتية." Case 35 To 37 GetMedicalCheckup = "فحص بكتيريا العقدية (Group B Streptococcus - GBS)." Case 38 To 40 GetMedicalCheckup = "فحوصات أسبوعية لمراقبة الجنين والأم." Case 41 To 42 GetMedicalCheckup = "مراقبة الحمل المتأخر، قد يتطلب تحفيز الولادة." Case Is > 42 GetMedicalCheckup = "الحمل تجاوز 42 أسبوعًا. يُنصح بالمتابعة الفورية مع أخصائي النساء والتوليد." Case Else GetMedicalCheckup = "متابعة الفحوصات الدورية مع الطبيب." End Select End Function ' دالة لتحديد النصائح Private Function GetPregnancyTips(ByVal trimester As EnmTrimester, ByVal IsMultiplePregnancy As Boolean) As String Dim GeneralTips As String, NutritionTips As String, ExerciseTips As String Select Case trimester Case EnmTrimester.First GeneralTips = "تجنب الأطعمة النيئة، ومراجعة الطبيب." NutritionTips = "تناول أطعمة غنية بحمض الفوليك (مثل السبانخ والعدس) وفيتامين B6 لتقليل الغثيان." ExerciseTips = "مارسي المشي الخفيف (20-30 دقيقة يوميًا) وتمارين التنفس لتخفيف التوتر." Case EnmTrimester.Second GeneralTips = "حركة الجنين تبدأ، والتغذية مهمة." NutritionTips = "زيدي السعرات بحوالي 300 سعرة يوميًا، ركزي على البروتين (مثل الدجاج والبقوليات) وأوميغا-3 (مثل السلمون)." ExerciseTips = "جربي اليوغا الخاصة بالحمل، تمارين تقوية الحوض (مثل Kegel)، أو السباحة الخفيفة." Case EnmTrimester.Third GeneralTips = "الاستعداد للولادة، وزيادة الوزن." NutritionTips = "تناولي أطعمة غنية بالحديد (مثل السبانخ والكبد) والكالسيوم (مثل الحليب والزبادي)، واشربي كميات كافية من الماء." ExerciseTips = "مارسي تمارين الإطالة لتحسين وضعية الجسم، المشي البطيء، وتمارين التنفس للتحضير للولادة." End Select GetPregnancyTips = GeneralTips & vbCrLf & "التغذية: " & NutritionTips & vbCrLf & "التمارين: " & ExerciseTips If IsMultiplePregnancy Then GetPregnancyTips = GetPregnancyTips & vbCrLf & "ملاحظة: الحمل المتعدد قد يتطلب متابعة طبية إضافية." End If End Function ' دالة لتوليد تقرير الحمل Private Function GeneratePregnancyReport(ByVal Results As Collection) As String Dim Report As String Report = "تقرير الحمل" & vbCrLf & String(30, "=") & vbCrLf Report = Report & "تاريخ آخر دورة شهرية: " & FormatDate(Results("LMP")) & vbCrLf Report = Report & "التاريخ الحالي: " & FormatDate(Results("Today")) & vbCrLf Report = Report & "مدة الحمل الحالية: " & FormatWeeksDays(Results("Weeks"), Results("Days")) & vbCrLf Report = Report & "الشهر الحملي: الشهر " & Results("PregnancyMonth") & vbCrLf Report = Report & "الثلث الحملي: " & TrimesterToString(Results("Trimester")) & vbCrLf Report = Report & "تاريخ الولادة المتوقع: " & FormatDate(Results("EDD")) & vbCrLf Report = Report & "الوقت المتبقي: " & FormatWeeksDays(Results("RemainingWeeks"), Results("RemainingDaysMod")) & vbCrLf Report = Report & "وزن الجنين التقديري: " & Format(Results("Weight"), "0") & " جرام" & vbCrLf Report = Report & "طول الجنين التقديري: " & Format(Results("Length"), "0.0") & " سم" & vbCrLf Report = Report & "نصائح الحمل:" & vbCrLf & Results("Tips") & vbCrLf Report = Report & "التوصيات الطبية: " & Results("MedicalCheckup") & vbCrLf GeneratePregnancyReport = Report End Function ' ================================ ' دالة الحساب الرئيسية ' ================================ Public Function CalculatePregnancyInfo(ByVal LMP As Variant, ByVal CycleLength As Variant, ByVal IsMultiplePregnancy As Boolean, Optional ByVal Today As Date = 0) As Variant ' تعيين التاريخ الحالي إذا لم يُحدد If Today = 0 Then Today = Date ' التحقق من صحة المدخلات Dim ValidationResult As String ValidationResult = ValidateInputs(LMP, CycleLength, Today) If ValidationResult <> "" Then CalculatePregnancyInfo = Array(False, ValidationResult) Exit Function End If ' تحويل المدخلات إلى الأنواع الصحيحة Dim LMPDate As Date: LMPDate = CDate(LMP) Dim CycleLengthInt As Integer: CycleLengthInt = CInt(CycleLength) ' حسابات الحمل Dim GA_Days As Long: GA_Days = DateDiff("d", LMPDate, Today) Dim Weeks As Long: Weeks = GA_Days \ 7 Dim Days As Long: Days = GA_Days Mod 7 Dim GA_Months As Double: GA_Months = Weeks / 4.3 Dim EDD As Date: EDD = GetEDD(LMPDate, CycleLengthInt, IsMultiplePregnancy) Dim RemainingDays As Long: RemainingDays = DateDiff("d", Today, EDD) Dim RemainingWeeks As Long: RemainingWeeks = RemainingDays \ 7 Dim RemainingDaysMod As Long: RemainingDaysMod = RemainingDays Mod 7 Dim RemMonths As Double: RemMonths = RemainingWeeks / 4.3 Dim OvulationDate As Date: OvulationDate = GetOvulationDate(LMPDate, CycleLengthInt) ' حساب الوزن والطول Dim WeightResult As Variant: WeightResult = EstimatedWeight(Weeks, IsMultiplePregnancy) Dim TempWeight As Double: TempWeight = WeightResult(0) Dim LengthResult As Variant: LengthResult = EstimatedLength(Weeks, IsMultiplePregnancy) Dim TempLength As Double: TempLength = LengthResult(0) Dim MonthResult As Variant: MonthResult = GetPregnancyMonth(Weeks) Dim PregnancyMonth As Long: PregnancyMonth = MonthResult(0) ' تحديد الثلث الحملي Dim CurrentTrimester As EnmTrimester: CurrentTrimester = GetTrimester(Weeks) ' تحديد النصائح Dim Tips As String: Tips = GetPregnancyTips(CurrentTrimester, IsMultiplePregnancy) Dim MedicalCheckup As String: MedicalCheckup = GetMedicalCheckup(Weeks) ' التحقق من تجاوز 42 أسبوعًا أو الحمل المبكر Dim WarningMessage As String If WeightResult(1) Or LengthResult(1) Or MonthResult(1) Then WarningMessage = GetWarningMessage("PostTerm", Weeks, CurrentTrimester) ElseIf Weeks < 4 Then WarningMessage = GetWarningMessage("EarlyPregnancy", Weeks, CurrentTrimester) End If ' تجميع النتائج في Collection Dim Results As New Collection Results.Add LMPDate, "LMP" Results.Add Today, "Today" Results.Add CycleLengthInt, "CycleLength" Results.Add IsMultiplePregnancy, "IsMultiplePregnancy" Results.Add GA_Days, "TotalDays" Results.Add Weeks, "Weeks" Results.Add Days, "Days" Results.Add GA_Months, "GestationalMonths" Results.Add EDD, "EDD" Results.Add RemainingDays, "RemainingDays" Results.Add RemainingWeeks, "RemainingWeeks" Results.Add RemainingDaysMod, "RemainingDaysMod" Results.Add RemMonths, "RemainingMonths" Results.Add OvulationDate, "OvulationDate" Results.Add TempWeight, "Weight" Results.Add TempLength, "Length" Results.Add PregnancyMonth, "PregnancyMonth" Results.Add CurrentTrimester, "Trimester" Results.Add Tips, "Tips" Results.Add MedicalCheckup, "MedicalCheckup" CalculatePregnancyInfo = Array(True, Results, WarningMessage) End Function ' دالة لتحديث واجهة النموذج Private Sub UpdateForm(ByVal Results As Collection, ByVal WarningMessage As String) If WarningMessage <> "" Then MsgBox WarningMessage End If Me.txtCurrentDate = FormatDate(Results("Today")) Me.txtCurrentDate.ControlTipText = "التاريخ الحالي بناءً على تاريخ النظام (YYYY-MM-DD)" Me.txtCycleLength = Results("CycleLength") Me.txtCycleLength.ControlTipText = "طول الدورة الشهرية بالأيام (عادةً 21-35 يومًا)" Me.chkMultiplePregnancy = Results("IsMultiplePregnancy") Me.chkMultiplePregnancy.ControlTipText = "حدد إذا كان الحمل متعددًا (مثل التوائم)" Me.txtWeeks = Results("Weeks") Me.txtWeeks.ControlTipText = "عدد الأسابيع منذ بداية الحمل" Me.txtDays = Results("Days") Me.txtDays.ControlTipText = "الأيام المتبقية بعد الأسابيع الكاملة" Me.txtCurrentGestation = FormatMonthsDays(Results("GestationalMonths"), Results("Days")) Me.txtCurrentGestation.ControlTipText = "العمر الحملي الحالي بالشهور والأيام" Me.txtTrimester = TrimesterToString(Results("Trimester")) Me.txtTrimester.ControlTipText = "الثلث الحملي الحالي (الأول، الثاني، الثالث)" Me.txtPregnancyTips = Results("Tips") Me.txtPregnancyTips.ControlTipText = "نصائح طبية وغذائية ورياضية تتعلق بالمرحلة الحالية من الحمل" Me.txtMonth = "الشهر " & Results("PregnancyMonth") Me.txtMonth.ControlTipText = "الشهر التقريبي من الحمل بناءً على عدد الأسابيع" Me.txtOvulationDate = FormatDate(Results("OvulationDate")) Me.txtOvulationDate.ControlTipText = "تاريخ التبويض المحتمل بناءً على تاريخ الدورة الشهرية (YYYY-MM-DD)" Me.txtWeek = "الأسبوع " & Results("Weeks") Me.txtWeek.ControlTipText = "رقم الأسبوع الحالي من الحمل" Me.txtWeeksAndDays = FormatWeeksDays(Results("Weeks"), Results("Days")) Me.txtWeeksAndDays.ControlTipText = "مدة الحمل الحالية بأسابيع وأيام" Me.txtTotalDays = FormatDays(Results("TotalDays")) Me.txtTotalDays.ControlTipText = "إجمالي عدد أيام الحمل حتى الآن" Me.txtEstimatedWeight = Format(Results("Weight"), "0") & " جرام" Me.txtEstimatedWeight.ControlTipText = "الوزن التقديري للجنين حسب عدد الأسابيع" Me.txtEstimatedLength = Format(Results("Length"), "0.0") & " سم" Me.txtEstimatedLength.ControlTipText = "الطول التقديري للجنين حسب عدد الأسابيع" Me.txtExpectedDeliveryDate = FormatDate(Results("EDD")) Me.txtExpectedDeliveryDate.ControlTipText = "تاريخ الولادة المتوقع بناءً على التبويض (YYYY-MM-DD)" Me.txtRemainingTime = FormatMonthsDays(Results("RemainingMonths"), Results("RemainingDaysMod")) Me.txtRemainingTime.ControlTipText = "المدة المتبقية حتى موعد الولادة بالشهور والأيام" Me.txtRemainingWeeks = FormatWeeksDays(Results("RemainingWeeks"), Results("RemainingDaysMod")) Me.txtRemainingWeeks.ControlTipText = "المدة المتبقية حتى الولادة بالأسابيع والأيام" Me.txtRemainingDays = FormatDays(Results("RemainingDays")) Me.txtRemainingDays.ControlTipText = "عدد الأيام المتبقية حتى الولادة" Me.txtMedicalCheckup = Results("MedicalCheckup") Me.txtMedicalCheckup.ControlTipText = "توصيات طبية بناءً على أسبوع الحمل" End Sub ' حدث تحديث النموذج Private Sub UpdateFormFromInputs() Dim Result As Variant Result = CalculatePregnancyInfo(Me.txtLastMenstrualDate, Me.txtCycleLength, Nz(Me.chkMultiplePregnancy, False)) If Result(0) Then UpdateForm Result(1), Result(2) ' عرض التقرير (يمكن إضافته إلى زر أو حدث لاحقًا) Debug.Print GeneratePregnancyReport(Result(1)) Else MsgBox Result(1) End If End Sub ' ================================ ' أحداث النموذج ' ================================ Private Sub txtLastMenstrualDate_AfterUpdate() txtLastMenstrualDate = FormatDate(txtLastMenstrualDate) UpdateFormFromInputs End Sub Private Sub txtCycleLength_AfterUpdate() UpdateFormFromInputs End Sub Private Sub chkMultiplePregnancy_AfterUpdate() UpdateFormFromInputs End Sub Private Sub Form_Load() Me.txtCurrentDate = FormatDate(Date) Me.txtCurrentDate.ControlTipText = "التاريخ الحالي بناءً على تاريخ النظام (YYYY-MM-DD)" End Sub وأخيرا المرفق الغنى ExpectedDeliveryDate(4).accdb

جعلها الله في ميزان حسناتكم وجزاكم الله عنا كل الخير .

أولاً :- تمنياتي لأستاذنا ابوجودي الشفاء العاجل باذن الله . ثانياً :- 📌 هذا مرجع دوال VBA المتوافقة مع النواتين (32 بت و64 بت) هذا المرجع يحتوي على جميع الدوال الشائعة التي يمكن استخدامها في VBA داخل Access، مع دعم للنواتين 32 بت و64 بت باستخدام #If VBA7 Then. 🔹 1- دوال استدعاء Windows API #If VBA7 Then Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Long, lParam As Any) As Long #Else Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If SendMessage – إرسال رسائل للنوافذ داخل النظام. PostMessage – إرسال رسائل غير متزامنة. FindWindow – العثور على نافذة بناءً على عنوانها. ShowWindow – التحكم في عرض أو إخفاء النافذة. GetSystemMetrics – الحصول على معلومات حول إعدادات النظام. 🔹 2- دوال التعامل مع الملفات #If VBA7 Then Public Declare PtrSafe Function CopyFile Lib "kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long #Else Public Declare Function CopyFile Lib "kernel32" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long #End If CopyFile – نسخ ملف من موقع إلى آخر. DeleteFile – حذف ملف معين. FindFirstFile – البحث عن أول ملف يتطابق مع نمط معين. FindNextFile – البحث عن الملفات التالية بنفس النمط. 🔹 3- دوال النظام (System Functions) #If VBA7 Then Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long #Else Public Declare Function GetTickCount Lib "kernel32" () As Long #End If GetTickCount – الحصول على عدد الثواني منذ تشغيل النظام. GetWindowsDirectory – استرجاع مسار مجلد Windows. GetSystemMetrics – استرجاع بيانات عن إعدادات النظام. 🔹 4- دوال إضافية مفيدة #If VBA7 Then Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As Any) As Long #Else Public Declare Function GetCursorPos Lib "user32" (lpPoint As Any) As Long #End If GetCursorPos – الحصول على موقع مؤشر الفأرة. SetCursorPos – تعيين موقع جديد لمؤشر الفأرة. GetActiveWindow – استرجاع النافذة النشطة حاليًا. GetDesktopWindow – استرجاع نافذة سطح المكتب الرئيسية.

من تواضع لله رفعه ، وانت من الأساتذة الذين لهم بصماتهم وأسلوبهم

اخي الفاضل انا لم اتسرع ولم احكم عليك .... ولكني حكمت على نفسي باني لست خبير ... وفعلا انا تلميذ لكم اخي الفاضل ... المقامات محفوظة

اعتقد بعد هذه الكوكبة من علمائنا الافاضل ..... وفي هذا الموضوع المهم والحيوي واقتراب موعد عدم اثراء أي برامج تعتمد عى 32 بت ...... وحتى تحصين برامجنا التي نعمل عليها . لابد من مناقشتها وهنا فرصة عظيمة لذلك . ولكي تتم المناقشة لابد من مشاركة مهندسنا (أبو جودي) الذي نأمل أن يشاركنا في هذا الطرح . تحياتي للجميع .

وعليكم السلام اهلا اخي فادي 🙂 اهم شيء في هذا الموضوع، هو الرجوع الى تعليمات مايكروسوفت في التعامل مع دوال نواة 64 بت ، في الرابط التالي: https://www.microsoft.com/en-us/download/details.aspx?id=9970 ملف النص في الرابط اعلاه يعطيك تفاصيل الدالة على نواة 64 بت. المثال الذي استعملته انت، وانا متأكد بأنك كنت حريص في انتقاء الدالة، توجد به 3 فروقات عن الدالة في ملف مايكروسوفت (السطر الثاني من ملف مايكروسوفت) : والمسألة لا تتوقف عند هذا السطر فقط، فهناك دوال معقدة تحتاج الى استعمال if# في دالتي الخاصة. رجاء قراءة الموضوعين التاليين ، فطريقة العمل تختلفان ، وفيهما بعض الامثلة المختلفة: . .

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

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM 1) الأفضل هو تجاهل الصفوف الفارغة في عمود G بدلا من تقييد العرض بـ 51 صف فقط لأنك بذلك تمنع عرض أي بيانات جديدة تضاف لاحقا بعد الصف 51 أي إدخال جديد لن يظهر في الـ ListBox الكود يصبح محدودا وغير ديناميكي 2) بعد معاينة الملف لاحظت انك اسم الجدول على ورقة العمل باسم Tableau5 بينما الكود يشير إلى Tableau1 وهذا سيؤدي حتما إلى ظهور خطأ عند التشغيل لأن الكود يبحث عن جدول غير موجود وهده النقطة يمكننا تجاوزها إدا فهمنا ما تحاول فعله بالاعتماد على نطاق البيانات مباشرة من الورقة دون الحاجة لاستخدام جدول محدد أو إسمه مما يجعل الكود أكثر مرونة ولا يتأثر بتغيير الأسماء أو حذف الجداول وكدالك عرض كل الصفوف التي تحتوي على بيانات فعلية فقط مهما كان عددها 3) إذا كنت متأكد أن تقييد العرض على 51 صف فقط هو المطلوب ويراعي ظروف عملك يمكننا تعديل الكود ليقوم بعرض أول 51 صف من البيانات الفعلية فقط في النهاية الأمر يعود لاختيارك حسب متطلباتك هل ترغب أن أعدل لك الكود بحيث يعرض فقط أول 51 صف غير فارغ في العمود G ؟ أو تفضل التعديل الديناميكي الذي يعرض كل الصفوف الفعلية ويتجاهل الفراغات ؟

وعليكم السلام ورحمة الله وبركاته اشارك برأي من باب المشاركة ولست خبيرا ,,,,, لأنك انت من طلب من غير الخبراء المشاركة 😃 عن تعديل الكود اعتقد يجب النظر في كل المتغيرات والدوال مثلا هناك دوال تحتاج الى تعديل للعمل في بيئة 64 bit مثل ::::::::::::::: 1. FindWindow 2. GetWindowLong / SetWindowLong 3. GetTickCount 4. ShellExecute 5. Sleep 6. GetSystemMetrics 7. GetCursorPos 8. OpenProcess 9. CreateFile والله اعلم

فعلاً انا لاحظت تعليق انشاء موضوع جديد اتوقعت المشكلة من عندي لكن الحمد لله تم حل المشكلة وشكراً على الطرح يا معلمنا ابا خليل والشكر موصول للمهندسين Foksh - ابو جودي على إثرائهم للمواضيع بصفة عامة ... نفع الله بكم

بسم الله ما شاء الله عمل رائع جزاك الله كل خير

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

من باب النكاش لا النقاش الى ماذا استندت في :- ' حساب وزن الجنين المتوقع (بناءً على معادلة تقريبية) Select Case Weeks Case 8 To 12 EstimatedWeight = 1 + (Weeks - 8) * 6 ' نمو سريع في الثلث الأول (1-25 جم) Case 13 To 20 EstimatedWeight = 25 + (Weeks - 13) * 40 ' نمو في الثلث الثاني (25-300 جم) Case 21 To 30 EstimatedWeight = 300 + (Weeks - 21) * 80 ' زيادة مطردة (300-1100 جم) Case 31 To 40 EstimatedWeight = 1100 + (Weeks - 31) * 200 ' نمو كبير في الثلث الثالث (1100-3500 جم) Case Else EstimatedWeight = 3500 ' الحد الأقصى التقريبي عند الولادة End Select Me.txtEstimatedWeight = Format(EstimatedWeight, "0") & " جرام" ' حساب طول الجنين المتوقع (بالسنتيمتر) Select Case Weeks Case 8 To 12 EstimatedLength = 2 + (Weeks - 8) * 1.5 ' نمو سريع (2-8 سم) Case 13 To 20 EstimatedLength = 8 + (Weeks - 13) * 2 ' نمو مطرد (8-22 سم) Case 21 To 30 EstimatedLength = 22 + (Weeks - 21) * 2.5 ' زيادة في الطول (22-45 سم) Case 31 To 40 EstimatedLength = 45 + (Weeks - 31) * 0.5 ' نمو بطيء (45-50 سم) Case Else EstimatedLength = 50 ' الحد الأقصى التقريبي عند الولادة End Select Me.txtEstimatedLength = Format(EstimatedLength, "0.0") & " سم" حيث أن هذه المعادلات ليست دقيقة طبياً ، لأن وزن وطول الجنين يعتمدان على عوامل وراثية ، تغذوية ، وصحية للأم . في التطبيقات الطبية الحقيقية ، يتم الاعتماد على جداول معتمدة (مثل منحنيات WHO) أو قياسات السونار .

جزاكم الله خيرا

أحسنتم أخي الأستاذ @محمد هشام. ، ما تفضلتم به صحيح ولا شك فيه ، خصوصاً أن الدوال التي ذكرتها تعود بقيمة رقمية يتم تحويل التاريخ أو الوقت فيها الى رقم يفهمه اكسل أو آكسيس ، مما سيضطرني كمستخدم لتحويل تنسيق الخلية الى نوع تاريخ ( على سبيل المثال ) ليتم اظهار القيمة الرقمية على شكل تاريخ .. وعلى سبيل المثال ، قمت بتجربة بسيطة للتحقق مما اذا كان الناتج من فكرتي يتم قراءته كتاريخ أم لا ، باستخدام المعادلة :- = DATEDIF(M2, TODAY(), "y") & " سنوات و " & DATEDIF(M2, TODAY(), "ym") & " أشهر و " & DATEDIF(M2, TODAY(), "md") & " أيام" وطبعاً هي لكسب المعلومة ليس أكثر ( ) ، فقد كانت النتيجة صحيحة عند التعامل مع القيمة كقيمة تاريخ ، ( شريطة انني لم أغير تنسيق الخلية الى تاريخ ) .. ولكن ما تفضلتم به يثري معلوماتي في أكسل . فشكراً لكم أخي الفاضل رحابة صدركم ، وشرحكم الجميل

وعليكم السلام ورحمة الله تعالى وبركاته، شكرًا للأخ @Foksh على مشاركته القيمة وبعد إذنه طبعا بالفعل الدالة: =TEXT(L2, "mmm dd, yyyy") مفيدة جدا لإظهار التاريخ بتنسيق واضح لكنها ترجع نصا وليس تاريخا فعليا مما قد يعيق عمليات مثل الترتيب أو الفلترة أو الحسابات المرتبطة بالتواريخ كبديل يعيد قيمة التاريخ الأصلية بدون الوقت وبشكل يمكن Excel التعامل معه كتاريخ حقيقي يمكن استخدام: =INT(L2) أو =QUOTIENT(L2, 1) كلاهما يفصل التاريخ عن الوقت تماما (وتظل قابلة للحسابات مثل التصفية والفرز) ملاحظة: تأكد من تنسيق الخلايا الناتجة كـ [تاريخ] لضمان عرضها بالشكل الصحيح وإذا كنت مهتما أيضا بفصل الوقت بشكل مستقل فيمكن استخدام: =L2 - INT(L2) وهي مفيدة إذا احتجت لاحقا إلى عرض الوقت وحده أو تحليله تحياتي وتقديري للجميع 2 تمديد.xlsx

تفضل أخي الفاضل ملفين أحدهما معادلات و الآخر أكواد. اختر ما يحلو لك. ناجح-راسب.xlsm ناجح-راسب.xlsx

و عليكم السلام ورحمة الله و بركاته استخدام Power Query الخطوات: فتح ملف إكسيل جديد: افتح ملف إكسيل جديدًا أو موجودًا حيث تريد دمج البيانات. الوصول إلى Power Query: انتقل إلى علامة التبويب البيانات (Data). انقر على الحصول على البيانات (Get Data) من مجلد (From Folder). تحديد المجلد: اختر المجلد الذي يحتوي على ملفات الإكسيل التي تريد دمجها. ستظهر نافذة تعرض جميع الملفات في المجلد. انقر على تحميل (Load) أو تحويل البيانات (Transform Data) لفتح محرر Power Query. دمج البيانات: في محرر Power Query، سترى قائمة بجميع الملفات. انقر على أيقونة دمج (Combine) بجوار العمود "Content". اختر الجدول أو الورقة (Sheet) التي تريد دمجها من كل ملف (إذا كانت تحتوي على أوراق متعددة). يمكنك تنظيف البيانات (مثل حذف الأعمدة غير الضرورية) قبل الدمج. تحميل البيانات: انقر على إغلاق وتحميل (Close & Load) لإرسال البيانات المددمجة إلى ملف الإكسيل الجديد. تحديث البيانات: إذا أضفت ملفات جديدة إلى المجلد لاحقًا، انقر بزر الفأرة الأيمن على الجدول في إكسيل واختر تحديث (Refresh) لتحديث البيانات. ملاحظة: تأكد أن جميع الملفات لها نفس الهيكلية (نفس أسماء الأعمدة وترتيبها) لتجنب الأخطاء.

و عليكم السلام ورحمة الله و بركاته تفضل نقل البيانات من عمود لاخر(2).xlsx

الله يحيك تفضل ملفين الأول بالمعادلات و الثاني بالكود مجموع المدة كاوقات.xlsx مجموع المدة كاوقات.xlsm

السلام عليكم ورحمة الله وبركاته هذا تحديث بسيط ومهم في نفس الوقت على هذه الأداة الجميلة 🙂 ( عون المثابر في الحصول على أسماء العناصر (الإصدار 3.0)) كما علمتم هذه الأداة صممتها بفضل الله في أكسس تقوم بإحضار وسرد أسماء العناصر لك لكي تستطيع نسخها ولصقها في أي مكان تريد بكل سهولة ويسر 🙂 شخصيا أستفدت كثيرا منها وسهلت علي الكثير من الجهد وقلصت من وقت العمل بحمد الله وفضله. :: ما الجديد في النسخة 3.0 :: تم إضافة خانة في الأخير خاصة بالجداول فقط .. : وهي عند اختيار الجدول يتم كتابة جمل SQL أستعلامات أساسية للجدول المختار مع ذكر أسماء حقول الجدول مع مراعاة أنواع الحقول وكتابتها بشكل سليم في الكود .. طبعا الأداة ستعطيك الجمل الاستعلامية الأربعة SELECT, INSERT INTO, UPDATE ,DELETE والكود الناتج جاهز للصقه مباشرة في محرر الأكواد VBA .. عليك فقط أن تقوم ببعض التعديلات الطفيفة كإزالة الحقول الزائدة أو الغير مستهدفة وكذلك تحديد الشرط Where في حال التحديث أو الحذف مثلا . :: لقطة للنسخة 3.0 :: وهذا مثال على جمل ال SQL الناتجة : ' SELECT statement Dim sqlSelect As String sqlSelect = "SELECT [ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB]" sqlSelect = sqlSelect & vbCrLf & " FROM [SampleTable]" '============================================================ ' INSERT INTO statement Dim sqlInsert As String sqlInsert = "INSERT INTO [SampleTable] ([ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB])" sqlInsert = sqlInsert & vbCrLf & " VALUES (" & var_ID & ", '" & var_FirstName & "', '" & var_LastName & "', '" & var_Gender & "', " & var_Age & ", '" & var_Email & "', '" & var_Phone & "', '" & var_Education & "', '" & var_Occupation & "', " & var_Salary & ", " & var_StaffNumber & ", " & IIf(var_IsActive, -1, 0) & ", #" & var_DOB & "#)" '============================================================ ' UPDATE statement Dim sqlUpdate As String sqlUpdate = "UPDATE [SampleTable]" sqlUpdate = sqlUpdate & vbCrLf & " SET [ID] = " & var_ID & ", [First Name] = '" & var_FirstName & "', [Last Name] = '" & var_LastName & "', [Gender] = '" & var_Gender & "', [Age] = " & var_Age & ", [Email] = '" & var_Email & "', [Phone] = '" & var_Phone & "', [Education] = '" & var_Education & "', [Occupation] = '" & var_Occupation & "', [Salary] = " & var_Salary & ", [StaffNumber] = " & var_StaffNumber & ", [IsActive] = " & IIf(var_IsActive, -1, 0) & ", [DOB] = #" & var_DOB & "#" sqlUpdate = sqlUpdate & vbCrLf & " WHERE [SomeField] = SomeValue" '============================================================ ' DELETE statement Dim sqlDelete As String sqlDelete = "DELETE FROM [SampleTable]" sqlDelete = sqlDelete & vbCrLf & " WHERE [SomeField] = SomeValue" الشرح القديم للأداة على اليوتيوب 🙂 متابعة ممتعة 😊👌🏼 ولا أستغني عن آراءكم وملاحظاتكم .. 🙂 لتحميل الملف :

السلام عليكم أعضاء منتدى أوفيسنا الغاليين في محاولة مني لاستثمار بعض اوقات الفراغ حاليا وايضا لاثراء المنتدى الجميل باي شكل اقدر عليه عسى ان تنفع مبتديء في مجال VBA حاولت استفيد من قدرات الذكاء الصناعي بشكل ما وقلت اعمل شرح وافي شامل بقدر المستطاع للـ VBA يشمل اكبر قدر ممكن من الامثلة والاوامر وقلت طبعا اشاركه هنا مع بعض لعله فيه افاده لاي أحد طبعا انا معملتش اي حاجة غير نسخ ولصق وشوية تنسيق بسيط جدا بس علشان ينفع يقرأ اي احد يقرأه ويستفيد ان شاء الله ولاحظ اي اخطاء املائيه او تنسيقية او اخطاء في الاكواد نعدلها والله الموفق واعذروني للتقصير مرفق الفصل الاول والثاني والثالث واذكركم بس دا كتاب تم تأليفه بواسطة السيد ذكاء بيه الاصطناعي يعني مش انا وكمان مفيش تنسيق ولا مراجعه بالقدر .. العمر بيفرق والنظر راح وربنا يوفق يارب Ch1 Ch2 Ch3

لان الملف الذي ارفقته انت لا يفبل حفظ الاكواد الفكرة واضحة والمشكلة واضحة تفس الشرخ في الاعلى بطريفة اخرى تابعنى في الشرح الملف المرفق من طرفكم كما في الصورة اي ملف ينتهي كما في الدائرة الحمراء لا يقبل اي كود انت في الحقيقة لا تحفظ الملف بعد الانتهاء من الشغل عندما تقوم يغلق الملف وبه الكود تاتى رسالة كما في الصورة عتد الضغط على حفظ تاتى رسالة اخرى كما بالصورة اذا اخنرت تعم سيتم حفظ الملف وسيحذف الكود من الملف واذا اخنرت لا سينقلك الى كما بالصورة طبق كما في الصورة واختر مكان الحفظ سطح المكنب مثلا ثم حفظ هنا تم انشاء ملف اخر غير الاول بنفس الاسم ولكن تهايته كنا في الدائرة الحمراء تخنلف وسيخفظ الكود عند فتح الملف الذي تم انشائه وليس الملف الاول ستجد به الكود هذا ما لدي والله اعلم لك كل التقدير والاحترام

إدن لنجرب هدا Option Explicit Sub Remplissez() On Error GoTo SupApp Const FontName As String = "Arial" Const ky As Long = 5: Const timeCol As Long = 4 Const colName As Long = 2: Const iRow As Long = 7 Const xCOLOR As Long = 42495: Const lastCol As Long = 34 Dim lastRow As Long, i As Long, col As Long, r As Long, n As Long Dim tmps As Boolean, xWeekend As Boolean, sDate As Date, cnt As Date Dim key As String, sName As String, dayName As String, status As String Dim OnRng As Variant, rng As Variant, cnts As Variant, tmp As Object, j As Object Dim Icon As String, xAbsen As String, name As String, sTime As String, a As Range Icon = ChrW(&H2705): xAbsen = ChrW(&H274C) Dim dest As Worksheet: Set dest = Sheets("الاستمارة") Dim CrWS As Worksheet: Set CrWS = Sheets("التواريخ") lastRow = dest.Cells(dest.Rows.Count, 4).End(xlUp).Row Set tmp = CreateObject("Scripting.Dictionary") Set j = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False: .Calculation = xlCalculationManual End With For r = 4 To CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row If Trim(CrWS.Cells(r, 3).Value) = "عطلة" Then tmp(CLng(CrWS.Cells(r, 1).Value)) = True End If Next For r = 4 To CrWS.Cells(CrWS.Rows.Count, 5).End(xlUp).Row If CrWS.Cells(r, 5).Value <> "" Then name = Trim(CrWS.Cells(r, 5).Value) sDate = CrWS.Cells(r, 6).Value sTime = Trim(CrWS.Cells(r, 9).Value) status = Trim(CrWS.Cells(r, 7).Value) key = name & "|" & CLng(sDate) & "|" & sTime j(key) = status If sTime = "صباحي/مسائي" Then j(name & "|" & CLng(sDate) & "|صباحي") = status j(name & "|" & CLng(sDate) & "|مسائي") = status End If End If Next OnRng = dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value cnts = dest.Range(dest.Cells(ky, 5), dest.Cells(ky, lastCol)).Value rng = dest.Range(dest.Cells(ky + 1, 5), dest.Cells(ky + 1, lastCol)).Value For i = 1 To UBound(OnRng, 1) If Trim(OnRng(i, colName)) <> "" Then sName = Trim(OnRng(i, colName)) For col = 5 To lastCol n = col - 4 If IsDate(cnts(1, n)) Then cnt = cnts(1, n): dayName = rng(1, n) tmps = tmp.exists(CLng(cnt)) xWeekend = (dayName = "الجمعة" Or dayName = "السبت") sTime = Trim(OnRng(i, timeCol)) key = sName & "|" & CLng(cnt) & "|" & sTime status = IIf(j.exists(key), j(key), "") If tmps Or xWeekend Or status = "غائب" Or status = "مجاز" Or status = "متأخر" Then OnRng(i, col) = xAbsen Else OnRng(i, col) = Icon End If End If Next col Next i dest.Range(dest.Cells(iRow, 1), dest.Cells(lastRow, lastCol)).Value = OnRng With dest.Range(dest.Cells(iRow, 5), dest.Cells(lastRow, lastCol)) .Font.name = FontName: .Font.Bold = True .Interior.ColorIndex = -4142: .Font.Color = vbGreen For Each a In .Cells If a.Value = xAbsen Then a.Font.Color = vbRed a.Interior.Color = xCOLOR End If Next a End With With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With MsgBox "تم التحديث البيانات بنجاح", vbInformation Exit Sub SupApp: With Application .ScreenUpdating = True: .Calculation = xlCalculationAutomatic End With End Sub استمارة-بعض النتائج المطلوبة v2.xlsb

وجدت هذا الملف بأحد المواقع الأجنبية و قمت بعمل تعديل بسيط عليه لعله يفي بالغرض حاسبة حضور و انصراف و الأجر الشهري.xlsx

تفضل جرب هدا Option Explicit Sub Convert_Arabic() Dim WS As Worksheet, OnRng As Range, ky As Range Dim i As Integer, j As Integer, NumArr As Variant, tmp As Variant Dim val As String, c As String, newVal As String, n As Boolean NumArr = Array(ChrW(1632), ChrW(1633), ChrW(1634), ChrW(1635), _ ChrW(1636), ChrW(1637), ChrW(1638), ChrW(1639), ChrW(1640), ChrW(1641)) tmp = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9") Set WS = Sheets("Sheet1") Set OnRng = WS.UsedRange Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.ErrorCheckingOptions.BackgroundChecking = False For Each ky In OnRng If Not IsEmpty(ky.Value) And Not ky.HasFormula Then val = Trim(ky.Text): newVal = "": n = False If val Like "*[" & Join(NumArr, "") & "]*" Then GoTo SubApp If Right(val, 1) = "%" Then n = True: val = Left(val, Len(val) - 1) For i = 1 To Len(val) c = Mid(val, i, 1) If c Like "[0-9]" Then newVal = newVal & NumArr(CInt(c)) Else newVal = newVal & c End If Next i If n Then newVal = newVal & "%" ky.NumberFormat = "@": ky.Value = newVal End If SubApp: Next ky Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub أو يمكنك التنقل بينها على الشكل التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v2 .xlsb

Sub تحويل_الورقة_للعربية() Dim cell As Range ' تغيير اتجاه الورقة من اليمين إلى اليسار ActiveSheet.DisplayRightToLeft = True ' تغيير اتجاه الخلايا إلى من اليمين لليسار ActiveSheet.Cells.ReadingOrder = xlContext ' يمكنك تغييره إلى xlRTL ' تغيير المحاذاة إلى اليمين ActiveSheet.Cells.HorizontalAlignment = xlRight ' تغيير نوع الخط إلى خط عربي ActiveSheet.Cells.Font.Name = "Traditional Arabic" ' تكبير حجم الخط قليلاً ActiveSheet.Cells.Font.Size = 12 MsgBox "تم تحويل الورقة للعربية بنجاح!", vbInformation End Sub

إليك الطريقة لتغيير لغة Excel 2010 إلى العربية فقط: 1. فتح إعدادات اللغة في Office: افتح Excel. اضغط على: File (ملف) ← Options (خيارات) ← Language (اللغة) 2. تعيين اللغة العربية: في نافذة اللغة، سترى قسمين مهمين: Choose Editing Languages (لغات التحرير) Choose Display and Help Languages (لغة العرض والمساعدة) قم بما يلي: في قسم Display Language، اختر العربية ثم اضغط Set as Default (تعيين كافتراضي). في قسم Help Language أيضًا اختر العربية (اختياري). اضغط OK. إذا لم تجد اللغة العربية ضمن الخيارات، انتقل للخطوة التالية 👇 🧩 إذا لم تكن اللغة العربية مثبتة: عليك تحميل حزمة اللغة العربية لـ Office 2010. 📥 لتحميلها: افتح هذا الرابط (حسب نواة Office 32 أو 64 بت): حزمة اللغة العربية Office 2010 (32 بت) حزمة اللغة العربية Office 2010 (64 بت) بعد التحميل، قم بتثبيت الحزمة. أعد فتح Excel وارجع إلى الخطوات أعلاه لتعيين اللغة العربية كلغة العرض

بسم الله الرحمن الرحيم السلام عليكم ورحمه الله وبركاته اساتذتي واخوتى هذا الملف به فهرس لجميع المنتدي ليسهل البحث للاعضاء يوجد فورم يمكنك البحث بها كما يمكنكم استخدام الفلتر العادي وبمجرد الضغط على اي نتيجه من نتائج البحث يتم فتح صفحتها في المنتدي ولا انسي فضل استاذي الكبير ياسر خليل على المساعده في عمل الملف تم تحديث الملف يوم الخميس الموافق 10 - 04 - 2025 فهرس منتدي الاكسيل.xlsb

السلام عليكم ورحمة الله وبركاته تفضل ربما يفيدك هذا تم وضع معادلة في H5 واستعمال التنسيق الشرطي للخلايا من A5:H14 ويمكن زيادة هذا النطاق إلى أي نهاية دعواتكم لي بسعة الرزق في هذه الايام المباركة مطلوب من أوفيسنا الكرام.xlsx

استبدل "ActiveWorkbook.SaveCopyAs Filename:=strPathname & ".xlsm ب "ActiveWorkbook.SaveCopyAs Filename:=strPathname "& ".pdf