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

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 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

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذ @Moosak ❤️🌹 عدلة على مرفقك 😇 بضيف له بعد التحديث حقل ادراج نص مع حقل قناع على الرسالة ☕ بامكان للعميل اختيار النمط المناسب له او بس للمطور تخصيص الرسائل وتنسيقها للانجاز وتحكم لكافة الاجهزة ====================( بتحديث يكون نص والعنوان DlookUp من جدول تاخذ الرقم وتسبدله بنص والعنوان لامكانية تغير نص الرسالة والغات الثانية كتغير لغة او التصحيح وتعديل 1- تخصيص الرسائل من الازرار الى الخلفية وحجم الرسالة - نوع الخط -حجم الخط -تحجيم الازرار - تحديد نمط الازار - تغير الالوان - تعين خلفية وايقونة وصوت 2- تغير اتجاه الرسالة من اليمين الى اليسار والعكس -تغير محاذات القراءه يمين ويسار وتوسيط 3- تغير حواف اطار النص 4- حفظ باسم مع تغير الباكيج ........ ====================================( تحديث ) 1- اضافة زر وتحجيمة لتحديث احداثية الزر 2-اضافة الغاء الصوت 3- عداد الوقت للالغاء وغلق الرسالة او مرات عدد ظهور الرسالة حسب الطلب بعض التحسينات وتصحيح واستكمال بعده دمج باكيج الواجهة الرئيسية مع الرسائل الى ثيم tablet = Name packge 1 , Name packge 1 = ( Name packge 1 install تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) تحميل مرفق مع باكيج للتجربة https://www.mediafire.com/file/qysrlx6x8g81nos/V1+Full_Control_Buld_MSGBOX_with+Stly+ON+MS+ACCESS.rar/file

اداة البحث هذه قمت بمحاولة تجميع الافكار فيها بعناية وبترتيبها لمحاولة الوصول الى اقصى درجات الكفائة والمرونة الممكنة اولا : تعرية وتطهير النص والتحكم فى ذلك حسب الحاجة كما سبق التنويه عن هذه الجزئية فى هذا الموضوع ثانيا : التحكم فى اعداد مصادر البيانت :- (مصدر البيانات"جدول /استعلام" - الحقولالبحث المخصصة - امكانية اضافة حقل او اكثر يعتمد على تطهير النصوص ثالثا : آلية البحث بحيث يمكن البحث من خلال ( الكلمة تبدأ بـ - تنتهى بـ - يتضمن الكلمة فى امكان - او متطابق تماما او لو عدد الكلمات كثير يمكن كتابة جزء من كل كلمة فى نفس السجل ولا يشترط الترتيب ) مثال : نريد البحث فى السجل قيمة هذا السجل : 26675 فوزي عبد الحميد ابو الفتوح محمد سعده لو تم اختيار من إعدادت البحث : يحتوى على اكثر من كلمة او جزء من كلمه يفصل بينهم مسافة من إعدادت البحث ثم كتبنا فى مربع البحث : عب فت سع 66 نحصل على النتيجة اثناء كتابة الكود تم عمل جدول باسم : tblSearchSettings بحيث يتم حفظ الاعدادت الخاصة بعملية البحث والفرز والتصفية تم وضع القيم الافتراضية لاجراء عمليات البحث والفرز والتصفية المتعددة على اكمل وجهة فى حالة حذف الجدول الخاص باعدادت البحث كما انها تمثل مرونة قصوى لكل مستخدم على حدى فى حالة استخدام شبكة محلية يستطيع كل مستخدم الاحتفاظ بالاعدادت التى تناسبه دون التأثير على الاخرين اخيرا المرفق واترككم مع التجربة Search Utility V 3.0.2.accdb

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

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذي @ابو جودي ❤️🌹🌹 استعمل جدول الرسائل مع ادوات الميديا من مرفقك 😇 بعد اذن استاذ @Moosak ❤️🌹 عدلة شي بسيط بداله 😇 1- اضافة قائمة لادارج الرسائل فقط عدل على هذا كود بكتابة رقم فقط Dim NMSG_1 As String NMSG_1 = "101" MyMsgBox (NMSG_1), (NMSG_1), (NMSG_1), msg_Information, Btn_OK_Only, Arabic_Center - رقم مسلسل من عند الاضافة رسالة جديدة - تعديل على الرسالة بتصحيح والحذف! - نسيت اضيف رقم الرسالة بصندوق الرسالة عند الفتح كمرجع مع ادارة التحكم او مع العميل 2- اضافة قائمة الاخطاء وتغير كود والدالة عند الخطأ من الرقم الى جهاز و المستخدم ..الخ Dim GiveMeError As Recordset On Error GoTo GiveMe Me.Error = "/" Exit Sub GiveMe: ' MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description Dim strMsg As String: strMsg = "Error Description : " & vbCrLf & Err.Description Dim Title As String: Title = "Error Massage !" Dim SubTitle As String: SubTitle = "Error Number: " & Err.Number Dim Number_MX_Error As String '============( XLong '========================( Sand Error To Tablet Set GiveMeError = CurrentDb.OpenRecordset("Error_All_MSGBOX") GiveMeError.AddNew GiveMeError![Err_Number] = Err.Number GiveMeError![Error_Description] = Err.Description GiveMeError![User] = "Not Now _CommingSoon " GiveMeError![PC] = Environ("username") GiveMeError![Today] = Date GiveMeError![ToTime] = Time() GiveMeError![Name_Form] = Me.Form.name GiveMeError![Click_Button] = "GiveMe_Click()" & " -Name_Button: " & "تفعيل رسالة الخطأ عند الخطأ OnError" 'Me.Error.Caption GiveMeError.Update DoEvents 'Number_MX_Error = DMax("[ID]", "[Error_All_MSGBOX]") MyMsgBox strMsg, Title, SubTitle, msg_Critical, Btn_OK_Only, English_Left, False ' Resume GiveMe Exit Sub 3- تصحيح مسار عند التشغيل 4- اضافة الغاء الصوت او تفعيل ================================( تحديث 1- تعامل مع الدالة مثال اسم الجهاز 2- تغير ابعاد الزر نافذه تحدد اما ارتفاع او عرض ثم الحفظ 3- تغير ابعاد الواجهة 4 5 ....... تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) تحميل المرفق https://www.mediafire.com/file/14jm050l7a9q5jx/Link+Tablt+On+MsgBoX+V1-2+Full_Control_Buld_MSGBOX_with+Stly+ON+MS+ACCESS.rar/file

شكر استاذ Barna على الصبر والتحمل و المساعدة وربي يجعلها في ميزان حسناتك

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

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

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

ابحث في الفورم الجديد عن ::: Forms!تسجيل الحسابات!اسم العميل وغير عبارة تسجيل الحسابات باسم النموذج الجديد

وعليكم السلام ورحمة الله وبركاته ملف بحنوى على كود و7 طرق عد بالمعادلات اختر ما يناسبك عد الخلايا الرقمية.xlsb

السلام عليكم ورحمة الله وبركاته اكثر من مرة ادخل الى موضوعك عسى ان اقدم شيئا لحل مشكلة الملف ولكن اتركة للاسباب التالية :- زر ترحيل البيانات يعطى خطأ والسبب ارتباطه بملف اخر لا نعلم ما به واسم الملف ("نموذج فلترة ايام الغياب.xlsm") ربما على جهازك لا يظهر الخطأ لان الملف موجود به ولكن لدينا نظهر رسالة الخطأ Set sourceWorkbook = Workbooks.Open(sourcePath) Set destinationWorkbook = Workbooks("نموذج فلترة ايام الغياب.xlsm") الصفحات التي ليس لها علاقة بالطلب كان يجب حذفها والاكواد التي ليس لها علاق كذلك والبيانات بالملف كان ادراج 15 او 20 اسما يكفى بدل من اكثر من 1000 كان الاجدر ان حددت الاسم او رقم الصف لهذه الحالة او ميزنها بلون فمن لديه الوقت للبحث في 1000 اسم وهل هذا الخطأ للكل ام لبعض الحالات راجعت اول اسم والثاني والثالت وجدت الامور منطابقة واذا كانت هناك حالات كان تحديدها او تميزها بلون اخنصارا للوقت في انتظار توضيح طلبك اكثر وسيكون اعضاء المنتدى مستعدين لتقديم المساعدة لك ولغيرك ان شاء الله عذرا ولك كل الاحترام والتقدير

سؤال رائع أتمنى أن تجد الإجابة