اذهب الي المحتوي
أوفيسنا

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

عبد الرحيم 1

بواسطه عبد الرحيم 1
في قسم الأكسيس Access

 مشاركة

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

ابو جودي

ابو جودي

قام بنشر
قام بنشر
1 دقيقه مضت, Barna said:

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

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

رابط هذا التعليق
شارك
Barna

Barna

قام بنشر
قام بنشر

1.png

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

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

 

  • Like 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر (معدل)
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

 

تم تعديل بواسطه ابو جودي
  • Like 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
2 ساعات مضت, Barna said:

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

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

انا قلت 

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

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

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

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

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:

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

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

  • Haha 1
رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر

والان اخى الحبيب الاستاذ @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

Barna

قام بنشر
قام بنشر
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

 

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

رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر
منذ ساعه, Barna said:

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept