ابو جودي

وبما انى صعيدى ومش قادر افهم قصد حضرتك ارجوك بعد ما تنتهى من التعديلات التى تريدها ارفق مرفقا بهذه التعديلات لعلى افهم شيئا

بل جزاكم الله انتم كل الخير فى الدنيا والاخرة بكل حرف تعلمنا ولازلنا نتعلمه منكم وعلى اياديكم المباركة والحمد لله تعالى الذى جعلنى سببا فى ادخال الفرحة والسعادة على قلوبكم الطاهرة انا وافكارى وكل ما املك ملك يمينكم ومن يشكر من يا استاذى الجليل ويا معلمى القدير و والدى الحبيب لولاكم ولولا فضل الله تعالى لما كنا هنا اسال الله تعالى ان يبارك لكم فى عمركم وعلمكم وعملكم واهلكم و ولدكم احبكم فى الله ولله

تم حذف الاستعلامات تم عمل اغلاق للقاعدة تم عمل ضغط واصلاح للقاعدة بعد اعادة فتحها النتيجة بعد كل ما سبق Query: ~sq_cCopy Of frmReports~sq_cs3 -> Table: tblsaf Query: ~sq_cfrmBarPrint~sq_ct2 -> Table: tblGrPoinCount Query: ~sq_cfrmcomIn~sq_cname1 -> Table: tblnames Query: ~sq_cfrmcomIn5~sq_cname1 -> Table: tblNames Query: ~sq_cfrmcomIn5~sq_cqama -> Table: tblSaf Query: ~sq_cfrmEshtrakatNotic~sq_cCombo15 -> Table: tblEshtrakatType Query: ~sq_cfrmEshtrakatNotic~sq_ceshOffres -> Table: tblEshtrakatOffres Query: ~sq_cfrmlog~sq_cgateNm -> Table: tblMsgGate Query: ~sq_cfrmNames~sq_cJensya -> Table: tbljensya Query: ~sq_cfrmNames~sq_cمربع_تحرير_وسرد187 -> Table: tblAdres Query: ~sq_cfrmOrderItem~sq_cItmDesc -> Table: tblOrderItem Query: ~sq_cfrmsecurity~sq_ccompname -> Table: tblUsers Query: ~sq_ffrmEshtrakatNotic -> Table: tblEshtrakatTsdeed Query: ~sq_ffrmNmadg -> Table: tblNmadg Query: ~sq_ffrmOrdersIn -> Table: tblOrderDetails Query: ~sq_ffrmRaes -> Table: tblRaese Query: ~sq_rRepHdorTfseelStud -> Table: tblcomInX الحمد لله ... لله الفضل والحمد والمنه هل تريد اى شئ أخر يا استاذى الجليل ومعلمى القدير و والدى الحبيب

والدى الحبيب هذه تجربتى ومحاولتى هذا ما حصلت عليه من الكود الذى قدمته لكم قبل قليل من مرفقكم الاخــــير Query: ~sq_cCopy Of frmReports~sq_cs3 -> Table: tblsaf Query: ~sq_cfrmBarPrint~sq_ct2 -> Table: tblGrPoinCount Query: ~sq_cfrmcomIn~sq_cname1 -> Table: tblnames Query: ~sq_cfrmcomIn5~sq_cname1 -> Table: tblNames Query: ~sq_cfrmcomIn5~sq_cqama -> Table: tblSaf Query: ~sq_cfrmEshtrakatNotic~sq_cCombo15 -> Table: tblEshtrakatType Query: ~sq_cfrmEshtrakatNotic~sq_ceshOffres -> Table: tblEshtrakatOffres Query: ~sq_cfrmlog~sq_cgateNm -> Table: tblMsgGate Query: ~sq_cfrmNames~sq_cJensya -> Table: tbljensya Query: ~sq_cfrmNames~sq_cãÑÈÚ_ÊÍÑíÑ_æÓÑÏ187 -> Table: tblAdres Query: ~sq_cfrmOrderItem~sq_cItmDesc -> Table: tblOrderItem Query: ~sq_cfrmsecurity~sq_ccompname -> Table: tblUsers Query: ~sq_ffrmEshtrakatNotic -> Table: tblEshtrakatTsdeed Query: ~sq_ffrmNmadg -> Table: tblNmadg Query: ~sq_ffrmOrdersIn -> Table: tblOrderDetails Query: ~sq_ffrmRaes -> Table: tblRaese Query: ~sq_rRepHdorTfseelStud -> Table: tblcomInX Query: QPointCritrDate -> Table: tblPoints Query: Qpointes -> Table: tblGrPoin Query: Qtsmyh -> Table: tbltsmyah هل النتيجة صحيحة ام هناك جداول لم تأتى اسمائها ؟؟

استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل جرب كده الكود التالى فى استخراج اسماء الجدول بعد الحذف Sub ExtractTablesFromObjects() ' Declare necessary variables Dim db As DAO.Database Dim qry As QueryDef Dim frm As Access.Form Dim rpt As Report Dim ctrl As Control Dim obj As Object ' Use for iterating through Access objects Dim objName As Variant Dim tablesList As String Dim source As String Dim matches As Object Dim tableRegex As String ' Enable error handling On Error GoTo ErrorHandler ' Initialize the regular expression pattern for extracting table names tableRegex = "tbl\w+" ' Set the database object Set db = CurrentDb ' Initialize a dictionary to store unique table names Set matches = CreateObject("Scripting.Dictionary") ' Initialize the results string tablesList = "Extracted Tables from Database Objects:" & vbCrLf & vbCrLf ' Process queries to extract table names For Each qry In db.QueryDefs If Len(qry.SQL) > 0 Then source = qry.SQL Call ExtractTableNames(source, tableRegex, matches, "Query: " & qry.Name) End If Next qry ' Process forms to extract table names For Each obj In CurrentProject.AllForms objName = obj.Name DoCmd.openForm objName, acDesign, , , , acHidden ' Open the form in design mode Set frm = Forms(objName) source = frm.RecordSource If Len(source) > 0 Then Call ExtractTableNames(source, tableRegex, matches, "Form: " & objName) End If ' Process controls within the form For Each ctrl In frm.Controls If ctrl.ControlType = acComboBox Or ctrl.ControlType = acListBox Then source = ctrl.RowSource If Len(source) > 0 Then Call ExtractTableNames(source, tableRegex, matches, "Form: " & objName & " (Control: " & ctrl.Name & ")") End If End If Next ctrl DoCmd.Close acForm, objName, acSaveNo ' Close the form without saving Next obj ' Process reports to extract table names For Each obj In CurrentProject.AllReports objName = obj.Name DoCmd.openReport objName, acDesign, , , acHidden ' Open the report in design mode Set rpt = Reports(objName) source = rpt.RecordSource If Len(source) > 0 Then Call ExtractTableNames(source, tableRegex, matches, "Report: " & objName) End If DoCmd.Close acReport, objName, acSaveNo ' Close the report without saving Next obj ' Display the results in a message box and print to Immediate Window If matches.Count > 0 Then For Each objName In matches.Keys tablesList = tablesList & matches(objName) & vbCrLf Debug.Print matches(objName) ' Print each result to Immediate Window Next objName Else tablesList = "No tables were found in the database objects." Debug.Print "No tables were found in the database objects." ' Print a no-result message End If MsgBox tablesList, vbInformation, "Extracted Tables" Exit Sub ErrorHandler: ' Handle any errors MsgBox "An error occurred: " & Err.Description, vbExclamation, "Error" End Sub Sub ExtractTableNames(source As String, tableRegex As String, matches As Object, objectType As String) ' Declare necessary variables Dim regex As Object Dim match As Object ' Create a RegExp object for analyzing text Set regex = CreateObject("VBScript.RegExp") regex.Pattern = tableRegex regex.Global = True ' Search for table names using the RegExp If regex.Test(source) Then For Each match In regex.Execute(source) If Not matches.Exists(match.Value) Then matches.Add match.Value, objectType & " -> Table: " & match.Value End If Next match End If End Sub المفروض بعمل تشغيل الوظيفة : ExtractTablesFromObjects من محرر الاكواد تظهر اسماء الجداول فى رسالة وتتم طباعتها فى النافذه الفورية حتى بعد حذف الجدول

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

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

والدى الحبيب انا كانت مشكلتى فى العمل هو الاتى اكثر من 50 قاعدة بيانات خلفيه للجداول قاعدة واحدة امامية بها اما كل الجدول او بعض الجداول من بعض القواعد الخلفيه او جميعها كل قسم حسب الحاجة المشكلة انه تم بالخطا مسح الجدول المرتبطة وحدثت لى نفس المشكلة لابد ان افتح كل شئ لاعلم المصدر ثم اقوم باستيراد الجدول مرة اخرى من كل قاعدة طبعا المرفق السابق سهل العملية كثيرا ولكن كانت فكرتى ويا حبذا لو تناقشنى اياها عمل جدول باسم UsystblLinked على ان يكون به الحقول الاتيى اسم الجدول اسم القاعدة الخلفيه كلمة المرور المسار تفعيل للربط الالى حقل بولينى من النوع (نعم / لا) طيب لو اردنا كتابتها بعيدا عن الجدول اين نكتبها هل فى ملف تيكست مثلا فى مسار محدد ؟؟ انه كذلك عرضة لحذف اعتقدت ان جدول يبدأ بـ Usys سوف يكون مخفيا بشكل تلقائى ولن يكون فى متناول الجميع للعبث به وممكن تشفير بياناته لتأمين كلمات المرور للقواعد ان وجدوت و مازلت افكر انا فى حيرة من امرى

نعم يا والدى لانه انا وقعت فى نفس هذه المشكلة فى عملى وتسهيلا على فيما هو ات بعد ذلك اعيد ترتيب افكارى وبدات بالمرفق التالى وقبل وضع مشاركتك مباشرة كنت افكر فى عمل جدول يضم الاتى اسم القاعدة الخلفيه الجدول او الجدوال التى تم اختيارها من هذه القاعدة والمسار وكلمة المرور ان وجدت هذا لاعادة الربط البرمجى او عند الحاجة لحذف الجدول المرتبطة نهائيا اما يتم الربط اليا على اساس البيانات من هذا الجدول او اما اختيار القاعدة او القواعد من هذا النموذج حسب الحاجة ولازالت الافكار تتسارع ImportLinkedTable.accdb

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

اعتقد الافكار الممكن تحقيقها تكون بالشكل التالى قبل الحذف عمل الاتى حذف جدول تمب اسماء الجدول اضافة اسماء الجداول والقواعد كل فى حقل على حده وان اردت كذلك ممكن مسار كل قاعدة حذف الجداول وعند اعادة الربط البرمجى تعتمد على جدول التمب هذا وان كان جدول التمب فارغ يتم فتح نموذج طلب مسارات القواعد المراد استيراد جداولها انا قدرا اعمل على مشروع مشابه لهذه الافكار فى الوقت الراهن لذلك كانت الاكواد جاهزة سبحان الله والله كاتبها قبل قليل وهذه الوظيفة الشاملة لاسماء الجدول واسم القاعدة لكل جدول والمسار لكل قاعدة Sub ListLinkedTablesWithDBNameAndPath() Dim db As dao.Database Dim tdf As TableDef Dim tableName As String Dim linkedTables As String Dim dbPath As String Dim dbName As String Set db = CurrentDb linkedTables = "Linked Tables, Database Names, and Paths:" & vbCrLf For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then tableName = tdf.Name If Left(tableName, 3) = "tbl" Then dbPath = tdf.Connect dbName = Mid(dbPath, InStrRev(dbPath, "\") + 1) linkedTables = linkedTables & "Table: " & tableName & ", Database: " & dbName & ", Path: " & dbPath & vbCrLf End If End If Next tdf MsgBox linkedTables End Sub

وعليكم السلام ورحمة الله تعالى وبركاته لمعرفة اسماء الجداول المرتبطة Sub ListLinkedTables() Dim db As dao.Database Dim tdf As TableDef Dim tableName As String Dim linkedTables As String Set db = CurrentDb linkedTables = "Linked Tables:" & vbCrLf For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then tableName = tdf.Name If Left(tableName, 3) = "tbl" Then linkedTables = linkedTables & tableName & vbCrLf End If End If Next tdf MsgBox linkedTables End Sub ولمعرفة اسماء الجدول واسم القاعدة الخلفية لكل جدول Sub ListLinkedTablesWithDBName() Dim db As dao.Database Dim tdf As TableDef Dim tableName As String Dim linkedTables As String Dim dbPath As String Set db = CurrentDb linkedTables = "Linked Tables and Database Names:" & vbCrLf For Each tdf In db.TableDefs If Len(tdf.Connect) > 0 Then tableName = tdf.Name If Left(tableName, 3) = "tbl" Then dbPath = tdf.Connect dbPath = Mid(dbPath, InStrRev(dbPath, "\") + 1) linkedTables = linkedTables & "Table: " & tableName & ", Database: " & dbPath & vbCrLf End If End If Next tdf MsgBox linkedTables End Sub

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

بعد اذن استاذى الجليل ومعلمى القدير واخى الحبيب الاستاذ @Barna على حسب فهمى المطلوب الان تحديدا هو : مراعاة منح الامتياز للمنخرطين من السنة الماضية خلال الأشهر 1، 2، و3، مع عدم منح الامتياز بعد شهر 3 إذا لم يتم التسديد خلال السنة الحالية اذا انا فهمت صح جرب الكود التالى ' Function to check membership payment details and determine benefits eligibility Public Function CheckInkhirat(ByRef ID As Integer) As String On Error GoTo err_CheckInkhirat Dim currentYear As Integer Dim previousYear As Integer Dim totalPaid As Currency Dim paymentMarch As Boolean Dim paymentJuly As Boolean Dim currentMonth As Integer ' Get the current year and month currentMonth = Month(Date) If currentMonth < 4 Then currentYear = Year(Date) - 1 previousYear = currentYear - 1 Else currentYear = Year(Date) previousYear = currentYear - 1 End If ' Calculate total payments for the current year totalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & currentYear & " AND Loan_ID = 0"), 0) ' Check if partial payments were made in March and July paymentMarch = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & currentYear & " AND Month(Auto_Date) = 3"), 0) = 1500 paymentJuly = Nz(DLookup("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & currentYear & " AND Month(Auto_Date) = 7"), 0) = 1500 ' Grant benefits if paid full or in two installments within the allowed period If totalPaid = 3000 And Not paymentMarch And Not paymentJuly Then CheckInkhirat = "You are eligible for all benefits as you paid the full membership amount in one payment." ElseIf totalPaid = 3000 And paymentMarch And paymentJuly Then CheckInkhirat = "You are eligible for all benefits as you paid the membership amount in two installments." ElseIf currentMonth <= 3 Then ' Check for benefits based on the previous year's payment status Dim previousTotalPaid As Currency previousTotalPaid = Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & previousYear & " AND Loan_ID = 0"), 0) If previousTotalPaid = 3000 Then CheckInkhirat = "You are eligible for benefits due to your membership payment in the previous year." Else CheckInkhirat = "You are not eligible for benefits as your membership payment is incomplete." End If Else ' If not meeting conditions, no benefits granted CheckInkhirat = "You are not eligible for benefits as your membership payment is incomplete." End If Exit Function err_CheckInkhirat: MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Error" CheckInkhirat = "An error occurred while checking membership details." End Function ' Function to verify other payment-related conditions Public Function GetOther(ByRef ID As Integer) As Boolean On Error GoTo err_GetOther Dim rst As DAO.Recordset Dim MySQL As String Dim sadad As Boolean Dim anne As Integer Dim Rec As Integer Dim tot As Boolean ' Determine the current year based on the month If Month(Date) < 3 Then anne = Year(Date) - 1 Else anne = Year(Date) End If ' Check if the payment status (sadad) is true for the current year sadad = Nz(DLookup("sadad", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & anne), False) If Not sadad Then GetOther = False Exit Function End If ' Query the loan records for the current year MySQL = "SELECT Auto_ID, EmployeeID, Auto_Date, Loan_Type, Remarks, Year(Auto_Date) AS Dats " & _ "FROM tbl_Loans " & _ "WHERE Loan_Type = 'Inkhirat' AND EmployeeID = " & ID & " AND Year(Auto_Date) = " & Year(Date) & _ " ORDER BY Auto_Date" Set rst = CurrentDb.OpenRecordset(MySQL) ' Check record count If Not rst.EOF Then rst.MoveLast If Not rst.BOF Then rst.MoveFirst Rec = rst.RecordCount ' Additional checks for July If Month(Date) = 7 Then tot = (Nz(DSum("Payment_Made", "tbl_Loans", "EmployeeID = " & ID & " AND Year(Auto_Date) = " & Year(Date)), 0) = 3000) If Not tot Then GetOther = False rst.Close Exit Function End If End If GetOther = (Rec > 0) rst.Close Set rst = Nothing Exit Function err_GetOther: If Err.Number = 3021 Then ' No records found Resume Next Else MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Error" End If End Function يحتوي الكود على الدالتين: CheckInkhirat تتحقق من دفع رسوم الانخراط إما دفعة واحدة أو على دفعتين خلال السنة الحالية تضيف شرط السماح بالاستفادة من الامتيازات بناءً على الدفع في السنة السابقة، إذا كان الشهر الحالي أقل من أبريل GetOther تتحقق من شروط أخرى تتعلق بالاشتراك، مثل حالة الدفع (مؤشر sadad) والتحقق من سجلات القروض (Loans) للسنة الحالية تأكيد النقاط المحققة في الكود الشروط الزمنية للدفعات: شرط أن يتم دفع 3000 دج خلال الفترة من يناير إلى أغسطس أو دفع 1500 دج في مارس و1500 دج في يوليو الامتياز للسنة السابقة عند الدخول في السنة الجديدة يمكن للمنخرطين في السنة السابقة الاستفادة خلال الأشهر الثلاثة الأولى (يناير، فبراير، مارس).

1. هيكلة قاعدة البيانات أضف الحقول والجداول التالية لتمكين النظام من دعم كلا الطريقتين: أ. جدول الاشتراكات (tblSubscriptions) CustomerID: معرّف الزبون. StartDate: تاريخ بداية الاشتراك. SubscriptionType: نوع الاشتراك (شهري/سنوي/رصيد). DurationDays: عدد الأيام إذا كان الاشتراك محددًا (مثل 30 يومًا). BalanceDays: عدد الأيام المتبقية في حال كان الاشتراك بالرّصيد. ب. جدول الإيقافات (tblPauses) لإدارة فترات التوقف للزبائن: PauseID: معرّف التوقف. CustomerID: معرّف الزبون. PauseStartDate: تاريخ بداية التوقف. PauseEndDate: تاريخ نهاية التوقف. PauseDays: عدد أيام التوقف المحسوبة (للاحتساب السريع). 2. آلية العمل حسب نوع الاشتراك أ. الاشتراك الشهري أو السنوي يتم التعامل معه وفق النظام الحالي (إضافة الأيام المؤقتة إلى مدة الاشتراك عند التوقف المؤقت). ب. الاشتراك بالرصيد عند إنشاء اشتراك جديد، يتم إدخال عدد أيام الخدمة في BalanceDays. عند كل توقف، يتم طرح أيام التوقف من BalanceDays. عند استخدام الخدمة، يتم تحديث الرصيد المتبقي بعد حساب الأيام المستفاد منها. 3. واجهة المستخدم أ. اختيار نوع الاشتراك أضف خيارًا جديدًا في النموذج لتحديد نوع الاشتراك: شهري/سنوي/رصيد. ب. إدارة التوقفات أضف نموذجًا فرعيًا لإدارة فترات التوقف ضمن شاشة الاشتراكات: إدخال تاريخ بداية التوقف وتاريخ النهاية. تحديث BalanceDays أو DurationDays حسب نوع الاشتراك. ج. عرض تفاصيل الاشتراك عند عرض بيانات الزبون، أظهر: عدد الأيام المتبقية في الاشتراك (لجميع الأنواع). تواريخ التوقفات إن وجدت. 4. تحديث الإشعارات عند الاشتراك الشهري/السنوي: احسب تاريخ انتهاء الاشتراك بعد إضافة فترات التوقف. عند الاشتراك بالرصيد: اعرض الإشعار فقط إذا كان الرصيد (BalanceDays) صفرًا. 5. التقارير أنشئ تقريرًا يعرض: جميع الاشتراكات المنتهية أو التي على وشك الانتهاء. عدد الأيام المتبقية لكل زبون. فترات التوقف للزبائن. مثال عملي زبون بالاشتراك الشهري: يبدأ الاشتراك في 1 نوفمبر لمدة 30 يومًا. توقف مؤقتًا لمدة 7 أيام. تاريخ انتهاء الاشتراك يصبح: 7 ديسمبر. زبون بالاشتراك بالرّصيد: يبدأ برصيد 365 يومًا. استهلك 90 يومًا وسافر لمدة 30 يومًا. الرصيد المتبقي: 275 يومًا.

طيب فعلا والله مش فاضى الان غصب عنى ابشر بعد ان انتهى من عملى سوف اضع المرف ان لم يسبقنى اليه احد لكن الجزء الاخير خالص من الكود هو الزتونه ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

ههههههه انا جاوبت فى سرى ينفع لا بلاش هزار لحسن حد يزعق لى انا بالفعل حضرتت الاجابة وفى آخر لحظة تراجعت عن عمل المشاركة ورفع المرفق السبب: بكل صراحة لم أكن راضيا عنها جارى العمل على تعديل اكواد لتكون الإجابة شاملة و كافية و وافيه بقدر الإمكان للإقتراب قدر الإمكان من أقرب درجات الكمال لأكون راض عن المشاركة

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

هلا والله.. والله اشتقنا يا اهلا بمفاجئاتك انت لازم تطلع عنيننا يا استاذنا الغالى انا قلت كتبت الكود على حسب المشكلات اللى واجهتنى وفتها بس ولا يهمك انت تأمر من عيونى بس استبدل الدالة التالية Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD or YYYY-DD-MM) intYear = CInt(strPartOne) If CInt(strPartTwo) > 12 Then ' Format: YYYY-DD-MM intDay = CInt(strPartTwo) intMonth = CInt(strPartThree) Else ' Format: YYYY-MM-DD intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) End If ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub واستبدل السطر الخاص بالمصفوفة المصفوفة القديمة بالمصفوفة الاتية SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "-", "#", "@", "+", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) المرفق بعد التعديلات RectifyDate (V 2).accdb

بعد اذن استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr فعلا الموضوع مهم وملح جدا جدا لمن يقع فى هذه الورطة خاصة مع كثرة عدد السجلات التى تحتوى على صيغ تواريخ مختلفة وبالاخص لو كانت بها مشاكل اثراء للموضوع صادفنى هذه المشكلة ذات مرة فى العمل وهذه هى الوظيفة التى قمت بكتابتها للتعامل مع مختلف الصيغ والتسيقات حسب المشاكل التى واجهتها آن ذاك Function RectifyDateFormat(inputString As String) As Variant ' Enable error handling ' This line sets up an error handling routine. If an error occurs in the code that follows, ' execution will jump to the ErrorHandler label, allowing for controlled error management. On Error GoTo ErrorHandler ' Remove leading and trailing spaces ' This line uses the Trim function to eliminate any spaces at the beginning and end of the input string. ' This is important for ensuring that the date format is clean and free of unnecessary spaces ' which could lead to incorrect parsing of date parts later in the function. inputString = Trim(inputString) ' Replace Indian numerals with standard numerals ' This block replaces Indian numerals (Unicode character codes from 1632 to 1641) with standard Arabic numerals (0-9). ' The loop iterates through the Unicode range for Indian numerals and replaces each occurrence ' in the input string with its equivalent standard numeral by calculating its index. Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' Replace non-standard symbols with hyphens ' This section defines an array of symbols that are considered non-standard for date formatting. ' The goal is to standardize the date input by replacing these symbols with hyphens, ' making it easier to parse the date parts later on. Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' Remove leading and trailing hyphens ' This line first replaces any occurrence of double hyphens (--) with a single hyphen (-). ' After replacing, Trim is used to remove any spaces around the string. ' This ensures that any malformed input resulting in multiple hyphens is corrected before further processing. inputString = CleanHyphens(inputString) ' Split the input string into date parts ' This line splits the cleaned input string into an array of date parts using the hyphen (-) as a delimiter. ' The result is stored in strDateParts, which will contain the individual components of the date (day, month, year). Dim strDateParts() As String strDateParts = Split(inputString, "-") ' Ensure the input contains exactly three parts ' This condition checks if the upper bound of the strDateParts array is not equal to 2. ' In VBA, the array index starts from 0, so an array with exactly three elements will have ' an upper bound of 2 (i.e., elements at index 0, 1, and 2). ' If the input does not contain exactly three parts, the function returns Null ' to indicate an invalid date format, and exits the function to prevent further processing. If UBound(strDateParts) <> 2 Then RectifyDateFormat = Null Exit Function End If ' Assign the split parts to variables, ensuring they are trimmed ' This line assigns the individual parts of the date from the strDateParts array ' to three separate variables (strPartOne, strPartTwo, strPartThree). ' The Trim function is used to remove any leading or trailing whitespace from each part. ' This ensures that any extra spaces do not affect the subsequent processing of date parts. Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' Debug output for each part ' This line outputs the individual parts of the date to the immediate window for debugging purposes. ' Debug.Print "Part One: " & strPartOne & " | Part Two: " & strPartTwo & " | Part Three: " & strPartThree ' Ensure that the parts can be converted to numbers ' This conditional statement checks if each of the date parts (strPartOne, strPartTwo, strPartThree) ' can be converted to a numeric value. It uses the IsNumeric function to evaluate whether ' each part is a valid number. If any of the parts cannot be converted to a number, it indicates ' an invalid date format. In this case, the function returns Null to signify that the input is not a valid date, ' and exits the function to prevent further processing. If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then RectifyDateFormat = Null Exit Function End If ' Declare integer variables for the day, month, and year ' These declarations create integer variables to hold the day, month, and year components of the date. ' These will be used for further processing and validation of the date before returning the formatted result. Dim intDay As Integer, intMonth As Integer, intYear As Integer ' Analyze the parts to determine their roles ' This block of code evaluates the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' Validate the final values ' This conditional checks if the final values for day, month, and year are valid. ' If any value is outside the expected range, the function returns Null to indicate an invalid date. If Not IsValidDate(intDay, intMonth, intYear) Then RectifyDateFormat = Null Exit Function End If ' Create the date and format it ' This line creates a date using the DateSerial function, which takes year, month, and day as parameters. ' The resulting date is then formatted as a string in the "dd/mm/yyyy" format. ' The formatted date string is assigned to the function's return value, RectifyDateFormat. RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ' This line exits the function normally. ' If no errors occur, the code will not reach the ErrorHandler section. ErrorHandler: ' Handle errors gracefully ' If an error occurs in the preceding code, this line sets the return value of the function to Null, ' indicating that the date format correction failed due to an error. RectifyDateFormat = Null End Function Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String ' This function iterates through an array of symbols that should be replaced with hyphens. ' Each symbol in the SymbolsToRemove array is checked, and if it's not a hyphen, ' it is replaced in the input string with a hyphen. Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function Private Function CleanHyphens(inputString As String) As String ' This function replaces double hyphens with a single hyphen and trims the input string. inputString = Trim(Replace(inputString, "--", "-")) ' Remove leading hyphens ' This loop checks if the first character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring starting from the second character. Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop ' Remove trailing hyphens ' This loop checks if the last character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring up to the second-to-last character. Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD) intYear = CInt(strPartOne) intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' This function checks if the provided day, month, and year are valid. ' It verifies that the month is between 1 and 12 and that the day is appropriate ' for the given month and year (not exceeding 31 for any month). IsValidDate = (intMonth >= 1 And intMonth <= 12) And _ (intDay >= 1 And intDay <= 31) And _ (intYear >= 1900 And intYear <= 2100) End Function وللتجربة لكل الحالات تقريبا من داخل المحرر '************************************************************************************************************************************* ' Sub: TestRectifyDateFormat ' Purpose: This subroutine tests the RectifyDateFormat function with various input date strings ' to ensure that the function handles different formats and returns the expected results. ' ' Usage: Call TestRectifyDateFormat to run the tests and print the results to the debug output. ' '********************************************************************** ' Author: officena.net™ , Mohammed Essam © , soul-angel@msn.com ® ' Date: October 2024 '********************************************************************** Sub TestRectifyDateFormat() Dim testDate As String Dim result As Variant ' Test various date formats testDate = "30/11/2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "2012-06-25" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "21/6/2015م" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = """ 9/1/2014""" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "30\11\2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1999/26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "25/1999/6" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1994/ 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5 1995 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "6 1996 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result End Sub RectifyDate.accdb

السلام عليكم ورحمة الله تعالى وبركاته تم تلافى الكثير من المشاكل وتم تحديث النسخة اليوم اليكم الاصدار الجديد ان شاء الله فى رأس الموضوع أو يمكنكم تحميل التعديل الاخيــر من >>---> تحميل التحديث للإصدار الأخير

ممكن توضيح اكثر يعنى اى قصدك من اضافة اى بيانات من مصدر خارجى ؟؟؟؟

فهم السؤال هو شطر الجواب ان لم يكن ثلثى الجواب والى الان لم يستطيع احد فهم السؤال المشكلة عند حضرتك فى عدم توضيح السؤال بشكل كاف وعدم وضع تصورات بشكل واف يا حبذا لو تضع النتيجة المطلوبة لاكثر من سجل

طيب وبعد التحليل للمرفق ومن غير اى اكواد ممكن جملة الاستعلام دى تحل لك كل مشاكلك SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, Nz([result], 0)/Nz([Cal], 1) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وما اخدت بالى من موضوع التقريب لو اردنا استخدام التقريب تكون جملة الاستعلام بالشكل التالى SELECT Table1.code, Table1.test, Table1.result, Table2.Cal, IIf(Nz([result], 0) <> 0 And Nz([Cal], 1) <> 0, Round(Nz([result], 0) / Nz([Cal], 1), 3), Nz([result], 0) / Nz([Cal], 1)) AS FinalCalc FROM Table1 INNER JOIN Table2 ON Table1.code = Table2.code; وهذا هو المرفق انظر الى الاستعلام مباشرة وغير القيم فى الحقل Cal تظهر لك النتيجة المرجوة مباشرة فى الحقل FinalCalc دا اذا كنت قدرت افهم انت عاوز ايه Cal error.accdb