حذف و ازالة الحركات و التشكيل من النص

[ابوخليل]

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

 وبعد البحث  وجدت التالي :

0x064B        فتحتان    Shift + W
0x064C        ضمتان    Shift + R
0x064D        كسرتان    Shift + S
0x064E        فتحة    Shift + Q
0x064F        ضمة    Shift + E
0x0650        كسرة    Shift + A
0x0651        شدة    Shift + ~
0x0652        سكون    Shift + X

ووجدت ايضا :
أن رموز unicode لحروف التشكيل العربية تبدأ من 240 وحتى 250 

من هنا :

http://withdotnet.net/2010/06/using-strings-with-combining-chars/

وأصل الكود هنا

 

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

Private Sub zer1_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim i, x As Integer
Set db = CurrentDb
 Set rs = db.OpenRecordset("tbl1")
  rs.MoveLast
  rs.MoveFirst
 For x = 1 To rs.RecordCount
Dim fld As String, wr As String, spa As String
wr = ""
fld = rs!text1
i = 1
Do While i <= Len(fld)
spa = Mid(fld, i, 1)
If Asc(spa) = 240 Or Asc(spa) = 241 Or Asc(spa) = 242 Or Asc(spa) = 243 Or Asc(spa) = 244 Or Asc(spa) = 245 Or Asc(spa) = 246 Or Asc(spa) = 247 Or Asc(spa) = 248 Or Asc(spa) = 249 Or Asc(spa) = 250 Then
Else
wr = wr & spa
End If
i = i + 1
Loop
rs.Edit
rs!text2 = wr
rs.Update
rs.MoveNext
Next x
Set db = Nothing
Set rs = Nothing
MsgBox "تمت العملية بنجاح"
End Sub

 

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

علما انه يمكن  اخراج النتيجة داخل الاستعلام  وهو برأيي افضل  .. وللهدية بقية ...

 

 

 

 

 

ازالة التشكيل.rar

[رمهان]

بارك الله فيك !

استفدت معلومات جديده!

شكرا ابو خليل

 

[محب لله ورسوله]

جزاك الله خيرا أخى الحبيب وونفع الله بك

وارجو منك  تعديل الكود بهذه الحروف من خلال هذا الكود

Public Function ReplaceString(In_Text As String) As String
    Dim X As Long
    Dim strChar As String
    Dim strReturn As String
    
    For X = 1 To Len(In_Text)
        strChar = Mid(In_Text, X, 1)
        Select Case strChar
            Case "أ", "إ", "آ"
                strChar = "ا"
            Case "ه"
                strChar = "ة"
            Case "ؤ"
                strChar = "و"
            Case "ئ", "ي"
                strChar = "ى"
''                تجاوز التشكيل عند البحث
            Case "َ", "ِ"
                strChar = ""
            Case "~", "ً"
                strChar = ""
            Case "ٍ", "ْ"
                strChar = ""
            Case "ُ", "ٌ", "ّ"
                strChar = ""
                 Case "ـ"
                strChar = ""
        End Select
        strReturn = strReturn & strChar
    Next
    DoEvents
    ReplaceString = strReturn
End Function

 

[ابوخليل]

وهذه طريقة لاستخراج النصوص  بلا تشكيل  عن طريق الاستعلام

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

Public Function delTshkeel(tshkeel As String)
Dim i As Integer
Dim fld As String, wr As String, spa As String
wr = ""
fld = tshkeel
i = 1
Do While i <= Len(fld)
spa = Mid(fld, i, 1)
If Asc(spa) = 240 Or Asc(spa) = 241 Or Asc(spa) = 242 Or Asc(spa) = 243 Or Asc(spa) = 244 Or Asc(spa) = 245 Or Asc(spa) = 246 Or Asc(spa) = 247 Or Asc(spa) = 248 Or Asc(spa) = 249 Or Asc(spa) = 250 Then
Else
wr = wr & spa
End If
i = i + 1
Loop
delTshkeel = wr
End Function

وهذا المرفق

استعلام حذف التشكيل.rar

[777msn]

شكرا على المعلومات القيمة

بارك الله فيك أخي