حركات التشكيل الفتحة التنوين ... الخ

**ابو جودي** · يناير 13, 2022

1 دقيقه مضت, Barna said:

لو عدلنا طغيانهم تتعدل معها للاسف الرحمان ....

طيب انا بس اشوف الكود :wink2: وان شاء الله راح لاقى حل بامر الله

**Barna** · يناير 13, 2022

طيب شوف الفانك ده ....

Public Function cleantxt(txt As String) As String
For Each itm In Array(ChrW("1649"), ChrW("1648"))
    txt = Replace(txt, CStr(itm), "ا")
Next
For Each itm In Array("َ", "ً", "ُ", "ٌ", "ِ", "ٍ", "ْ", "ّ", "ـ", ChrW("1761"), ChrW("1755"), ChrW("1619"), ChrW("1623"), ChrW("1750"), ChrW("1630"), ChrW("1762"), ChrW("1751"), ChrW("1765"), ChrW("1766") _
                       , ChrW("1754"), ChrW("1620"))
    txt = Replace(txt, CStr(itm), "")
Next
cleantxt = txt
End Function

**ابو جودي** · يناير 13, 2022

3 ساعات مضت, Barna said:

طيب شوف الفانك ده ....

Public Function cleantxt(txt As String) As String
For Each itm In Array(ChrW("1649"), ChrW("1648"))
    txt = Replace(txt, CStr(itm), "ا")
Next
For Each itm In Array("َ", "ً", "ُ", "ٌ", "ِ", "ٍ", "ْ", "ّ", "ـ", ChrW("1761"), ChrW("1755"), ChrW("1619"), ChrW("1623"), ChrW("1750"), ChrW("1630"), ChrW("1762"), ChrW("1751"), ChrW("1765"), ChrW("1766") _
                       , ChrW("1754"), ChrW("1620"))
    txt = Replace(txt, CStr(itm), "")
Next
cleantxt = txt
End Function

الفانك بتاعك دع حلو وطبعا شكرا على افكارك ومجهودك اولا :fff:

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

والفانك مكتوب فيه حجات بالعربى

تعالى بقى نفكر بالمقلوب 16696

ايه رايك فى الفانك ده

If strString & "" = "" Then Exit Function
Dim lngCtr As Long
Dim intChar As Integer
    For lngCtr = 1 To Len(strString)
        intChar = AscW(Mid(strString, lngCtr, 1))
        If intChar = 32 Or _
            intChar >= 1569 And intChar <= 1594 Or _
            intChar >= 1601 And intChar <= 1610 Or _
            intChar >= 1648 And intChar <= 1649 Then
            StripSpCharsOnly = StripSpCharsOnly & ChrW(intChar)
        End If
    Next lngCtr
    StripSpCharsOnly = Trim(StripSpCharsOnly)

بالطريقة دى اى شئ غير حروف العربى ما راح يظل موجود :yes:

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

Public Function StripSpChars(strString As String) As String

If strString & "" = "" Then Exit Function
Dim lngCtr As Long
Dim intChar As Integer
    For lngCtr = 1 To Len(strString)
        intChar = AscW(Mid(strString, lngCtr, 1))
        If intChar = 32 Or _
            intChar >= 1569 And intChar <= 1594 Or _
            intChar >= 1601 And intChar <= 1610 Or _
            intChar >= 1648 And intChar <= 1649 Then
            StripSpChars = StripSpChars & ChrW(intChar)
        End If
    Next lngCtr
    
    
    Dim itm As Variant
    For Each itm In Array(ChrW("1649"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1648") & ChrW("1604"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575") & ChrW("1604"))
    Next
    
    For Each itm In Array(ChrW("1610") & ChrW("1648"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1610") & ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1648"))
        StripSpChars = Replace(StripSpChars, CStr(itm), "")
    Next
    
    StripSpChars = Trim(StripSpChars)

End Function

تم تعديل يناير 13, 2022 بواسطه ابو جودي

**Barna** · يناير 14, 2022

18 ساعات مضت, ابو جودي said:

طيب انا بس اشوف الكود وان شاء الله راح لاقى حل بامر الله

طيب يا بشمهندس لازالت بعص النصوص عل شاكلة طغيانهم ..... انظر ....

**ابو جودي** · يناير 14, 2022

2 ساعات مضت, Barna said:

طيب يا بشمهندس لازالت بعص النصوص عل شاكلة طغيانهم ..... انظر ....

نعم سيدى واستاذى الجليل واخى الحبيب الاستاذ @Barna :fff:

انا قلت

18 ساعات مضت, ابو جودي said:

بالطريقة دى اى شئ غير حروف العربى ما راح يظل موجود

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

وهذا الروتين العام لكل الاشخاص ولذلك وضعت لكم الفانك منفردا كالاتى

18 ساعات مضت, ابو جودي said:

If strString & "" = "" Then Exit Function
Dim lngCtr As Long
Dim intChar As Integer
    For lngCtr = 1 To Len(strString)
        intChar = AscW(Mid(strString, lngCtr, 1))
        If intChar = 32 Or _
            intChar >= 1569 And intChar <= 1594 Or _
            intChar >= 1601 And intChar <= 1610 Or _
            intChar >= 1648 And intChar <= 1649 Then
            StripSpCharsOnly = StripSpCharsOnly & ChrW(intChar)
        End If
    Next lngCtr
    StripSpCharsOnly = Trim(StripSpCharsOnly)

بالطريقة دى اى شئ غير حروف العربى ما راح يظل موجود :yes:

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

ولانى كنت تعبان ما فكرت جيدا وما انتهيتولكن عند الانتهاء ان اردت الكود .. تدفع كام الأول

**ابو جودي** · يناير 14, 2022

والان اخى الحبيب الاستاذ @Barna :fff:

اليكم التجربة الاخيرة.... وجارى التيقن من النتيجة

Public Function StripSpChars(strString As String) As String

If strString & "" = "" Then Exit Function
Dim lngCtr As Long
Dim intChar As Integer
    For lngCtr = 1 To Len(strString)
        intChar = AscW(Mid(strString, lngCtr, 1))
        If intChar = 32 Or _
            intChar >= 1569 And intChar <= 1594 Or _
            intChar >= 1601 And intChar <= 1610 Or _
            intChar >= 1648 And intChar <= 1649 Then
            StripSpChars = StripSpChars & ChrW(intChar)
        End If
    Next lngCtr
    
    
    Dim itm As Variant
    
    For Each itm In Array(ChrW("1609") & ChrW("1648") & ChrW("32"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1609") & ChrW("32"))
    Next
    
    For Each itm In Array(ChrW("1569") & ChrW("1575"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1649"), ChrW("1648"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1605") & ChrW("1575") & ChrW("1606"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1605") & ChrW("1606"))
    Next
    
    For Each itm In Array(ChrW("1584") & ChrW("1575") & ChrW("1604") & ChrW("1603"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1584") & ChrW("1604") & ChrW("1603"))
    Next
    
    
    For Each itm In Array(ChrW("1575") & ChrW("1604") & ChrW("1589") & ChrW("1604") & ChrW("1608") & ChrW("1575") & ChrW("1577"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575") & ChrW("1604") & ChrW("1589") & ChrW("1604") & ChrW("1575") & ChrW("1577"))
    Next
         
    For Each itm In Array(ChrW("1609") & ChrW("1575"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
         
    StripSpChars = Trim(StripSpChars)

End Function

Strip Special Characters.zip

**Barna** · يناير 14, 2022

3 ساعات مضت, ابو جودي said:

ولانى كنت تعبان ما فكرت جيدا وما انتهيتولكن عند الانتهاء ان اردت الكود .. تدفع كام الأول

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

6 دقائق مضت, ابو جودي said:

والان اخى الحبيب الاستاذ @Barna :fff:

اليكم التجربة الاخيرة.... وجارى التيقن من النتيجة

Public Function StripSpChars(strString As String) As String

If strString & "" = "" Then Exit Function
Dim lngCtr As Long
Dim intChar As Integer
    For lngCtr = 1 To Len(strString)
        intChar = AscW(Mid(strString, lngCtr, 1))
        If intChar = 32 Or _
            intChar >= 1569 And intChar <= 1594 Or _
            intChar >= 1601 And intChar <= 1610 Or _
            intChar >= 1648 And intChar <= 1649 Then
            StripSpChars = StripSpChars & ChrW(intChar)
        End If
    Next lngCtr
    
    
    Dim itm As Variant
    
    For Each itm In Array(ChrW("1609") & ChrW("1648") & ChrW("32"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1609") & ChrW("32"))
    Next
    
    For Each itm In Array(ChrW("1569") & ChrW("1575"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1649"), ChrW("1648"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
    
    For Each itm In Array(ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1605") & ChrW("1575") & ChrW("1606"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575") & ChrW("1604") & ChrW("1585") & ChrW("1581") & ChrW("1605") & ChrW("1606"))
    Next
    
    For Each itm In Array(ChrW("1584") & ChrW("1575") & ChrW("1604") & ChrW("1603"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1584") & ChrW("1604") & ChrW("1603"))
    Next
    
    
    For Each itm In Array(ChrW("1575") & ChrW("1604") & ChrW("1589") & ChrW("1604") & ChrW("1608") & ChrW("1575") & ChrW("1577"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575") & ChrW("1604") & ChrW("1589") & ChrW("1604") & ChrW("1575") & ChrW("1577"))
    Next
         
    For Each itm In Array(ChrW("1609") & ChrW("1575"))
        StripSpChars = Replace(StripSpChars, CStr(itm), ChrW("1575"))
    Next
         
    StripSpChars = Trim(StripSpChars)

End Function

جاري التجربة ....

**ابو جودي** · يناير 14, 2022

اووووووووووف

الان بعد كل هذا العناء😡

تحصلت على ملف من موقع طبعة المصحف الشريف جااااااااااهز

hafsData_v18.xlsx

**Barna** · يناير 14, 2022

نعم هو ذاك .... هههههه

**ابو جودي** · يناير 14, 2022

منذ ساعه, Barna said:

لعلمك انا صحلت طريق ثانية مختصرة وبدون اكواد للبحث في الرسم العثماني الخاص بالمطبعة

اممممم ايه هو الطريق الثانى 🤔

تسجيل الدخول

حركات التشكيل الفتحة التنوين ... الخ

الردود الموصى بها

ابو جودي

Barna

ابو جودي

Barna

ابو جودي

ابو جودي

Barna

ابو جودي

Barna

ابو جودي

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information