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

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

في 13‏/1‏/2022 at 17:38, Barna said:

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

Expand

طيب انا بس اشوف الكود :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

في 13‏/1‏/2022 at 17:43, 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

Expand

الفانك بتاعك دع حلو وطبعا شكرا على افكارك ومجهودك اولا :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

في 13‏/1‏/2022 at 17:42, ابو جودي said:

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

Expand

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

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

في 14‏/1‏/2022 at 11:50, Barna said:

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

Expand

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

انا قلت

في 13‏/1‏/2022 at 20:05, ابو جودي said:

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

Expand

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

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

في 13‏/1‏/2022 at 20:05, ابو جودي 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:

Expand

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

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

**ابو جودي** · يناير 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.zipFetching info...

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

في 14‏/1‏/2022 at 14:40, ابو جودي said:

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

Expand

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

في 14‏/1‏/2022 at 17:45, ابو جودي 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

Expand

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

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

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

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

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

hafsData_v18.xlsxFetching info...

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

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

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

في 14‏/1‏/2022 at 17:51, Barna said:

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

Expand

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

تسجيل الدخول

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

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

ابو جودي

Barna

ابو جودي

Barna

ابو جودي

ابو جودي

Barna

ابو جودي

Barna

ابو جودي

Join the conversation

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

تصفح الموقع

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

Support

Important Information