ابو جودي

والله انا مسكين وممن ينتظرون الصدقات بلهفة واشتياق لذلك اتعشم فِىَّ وَجْه اللهِ انَّ يعدنى مِمَّنْ يَتَصَدَّقُ عَلَيْهُمْ وان كانت مشكلتكم مع الشرح ضع انت المرفق فقط وانا ان شاء الله افحص واحمص لافهم واضع الشرح المناسب قدر الامكان ولن لم يسعفنى الوقت حينها اضع التلميحات على اسطر الكود ليفهم منها الدراسون

طيب ممكن تتصدق وتتكرم علينا بمرفقك على طريقتك تسهيلا على الباحثين وطلاب العلم فبدلا من ان يبحثوا عن كل طريقه على حدى ويتيهون بين صفحات المنتدى ضع انت الطريقه ان اردت ان يدعوا لك طلاب العلم وانا يا استاذى القدير ومعلمى الجليل سوف أكون من أوائل طلاب العلم الذين يدعون الله لك اللَّهُمُّ وُسْعٍ لَهُ صَدْرُهُ لِيَتَحَمَّلُنِي انا وامثالي اللَّهُمَّ اُكْتُبْ لَهُ بِكُلُّ عُرْفِ حُسْنِهِ وَضَاعِفٍ لَهُ يَارَبِّ حُسْنَاتِهِ اضعافا مُضَاعَفَةً

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

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

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

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

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

سوف اقوم بالتجربة ان شاء الله واعود اليكم

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

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

تم حذف الاستعلامات تم عمل اغلاق للقاعدة تم عمل ضغط واصلاح للقاعدة بعد اعادة فتحها النتيجة بعد كل ما سبق 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