والرد من باب النكاش وبعيدا عن اى نقاش لان خلاص فاضل تكــه
هذه الحسابات تستند إلى نمو الجنين الطبيعي خلال مراحل الحمل وفقا لدراسات طبية وملاحظات حول كيفية تطور الجنين في الرحم في كل أسبوع من أسابيع الحمل
هذه الحسابات الدراسية طبعا
انت يا فؤش أفندى لازم تصحى الوحش اللى جوايا يعنى
الله يسامحك بقالى ساعه اكتب وصوابعى وجعتنى وانت عارف ليه
طيب بعد البحث لو اردنا نتائج اكثر دقة وبالاستناد الى هذا الموقع المتخصص
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
.thumb.gif.27c4a79ce23abc61b721f833e6899131.gif)
(1).thumb.gif.3369bc21e7688379f05218e4ca64e807.gif)
