اريد كود للتفقيط

السلام عليكم

هذا البرنامج المطلوب ولكن يحتاج الى تعديل كثير تحتاج فيه الى 2 تكستبوكس وزر

Dim l As Integer, s(4) As String, k1, k2, k3, k4
Public Function sam(k1, k2, k3, k4)
If k1 = 1 Then s(0) = " æÇÍÏ "
If k1 = 2 Then s(0) = " ÇËäíä "
If k1 = 3 Then s(0) = " ËáÇËÉ "
If k1 = 4 Then s(0) = " ÇÑÈÚÉ "
If k1 = 5 Then s(0) = " ÎãÓÉ "
If k1 = 6 Then s(0) = " ÓÊÉ "
If k1 = 7 Then s(0) = " ÓÈÚÉ "
If k1 = 8 Then s(0) = " ËãÇäíÉ "
If k1 = 9 Then s(0) = " ÊÓÚÉ "

'If k2 = 1 Then s(1) = ""
If k2 = 2 Then s(1) = " ÚÔÑæä"
If k2 = 3 Then s(1) = " 臂辊"
If k2 = 4 Then s(1) = " ÇÑÈÚæä"
If k2 = 5 Then s(1) = " ÎãÓæä"
If k2 = 6 Then s(1) = " ÓÊæä"
If k2 = 7 Then s(1) = " ÓÈÚæä"
If k2 = 8 Then s(1) = " ËãÇäæä"
If k2 = 9 Then s(1) = " ÊÓÚæä"

If k3 = 1 Then s(2) = " ãÆÉ"
If k3 = 2 Then s(2) = " ãÆÊÇä"
If k3 = 3 Then s(2) = " ËáÇË ãÆÉ"
If k3 = 4 Then s(2) = " ÇÑÈÚ ãÆÉ"
If k3 = 5 Then s(2) = " ÎãÓ ãÆÉ"
If k3 = 6 Then s(2) = " ÓÊ ãÆÉ"
If k3 = 7 Then s(2) = " ÓÈÚ ãÆÉ"
If k3 = 8 Then s(2) = " ËãÇä ãÆÉ"
If k3 = 9 Then s(2) = " ÊÓÚ ãÆÉ"

If k4 = 1 Then s(3) = " ÇáÝ "
If k4 = 2 Then s(3) = " ÇáÝíä "
If k4 = 3 Then s(3) = " ËáÇËÉ ÇáÇÝ "
If k4 = 4 Then s(3) = " ÇÑÈÚÉ ÇáÇÝ "
If k4 = 5 Then s(3) = " ÎãÓÉ ÇáÇÝ "
If k4 = 6 Then s(3) = " ÓÊÉ ÇáÇÝ "
If k4 = 7 Then s(3) = " ÓÈÚÉ ÇáÇÝ "
If k4 = 8 Then s(3) = " ËãÇäíÉ ÇáÇÝ "
If k4 = 9 Then s(3) = " ÊÓÚÉ ÇáÇÝ "

End Function
Private Sub Command1_Click()
l = Len(Text1.Text)
If IsNumeric(Text1.Text) = False Then
MsgBox "Enter number"
GoTo l1
End If
If l > 4 Then
MsgBox "Enter maximum 4 digits "
GoTo l1
End If
Text2.Text = ""
If l = 4 Then m = sam(Right(Text1.Text, 1), Mid(Text1.Text, 3, 1), Mid(Text1.Text, 2, 1), Left(Text1.Text, 1))
If l = 3 Then
Text1.Text = "0" & Text1.Text
m = sam(Right(Text1.Text, 1), Mid(Text1.Text, 3, 1), Mid(Text1.Text, 2, 1), Left(Text1.Text, 1))
End If
If l = 2 Then
Text1.Text = "00" & Text1.Text
m = sam(Right(Text1.Text, 1), Mid(Text1.Text, 3, 1), Mid(Text1.Text, 2, 1), Left(Text1.Text, 1))
End If
If l = 1 Then
Text1.Text = "000" & Text1.Text
m = sam(Right(Text1.Text, 1), Mid(Text1.Text, 3, 1), Mid(Text1.Text, 2, 1), Left(Text1.Text, 1))
End If
Text2.Text = s(3) & " æ " & s(2) & " æ " & s(0) & " æ " & s(1)
l1: '
End Sub

السلام عليكم

حقيقة لا ادري ما حدث

البرنامج المرفق اعلاه كان يعمل في جهازي و لكن بعد ان ارفقته في المنتدى و حاولت استعماله من المنتدى لاحظت ان الجزء المكتوب باللغة العربية قد تحول الى حروف انجليزية عشوائية فبدل ان اكتب الحرف (و) كتب aelig

و لا ادري ان كانت المشكة من نوع الخط ام من الجهاز اعتذر لك ( رنين) :(

فعلا الكود لا يعمل لذا امل منكم الرد في اسرع وقت ممكن

ارجو المساعدة كود التفقيط يا شباب عاجل جداً

هذا كود دالة التفقيط وأظن أن استعمالها ضمن البرنامج ليس مشكلة:

' دالة التفقيط الآلي
' برمجة محمد مهند عبادي 2003
Function words(D As Double, Optional F1 As String = "واحدة", _
Optional F2 As String, Optional F3 As String, Optional D1 As String = "جزء", _
Optional D2 As String, Optional D3 As String) As String
Dim P, P1, P2, P3, P4, w, w1, w2, w3, N, N1 As String
If IsNull(D) Or D = 0 Then
    words = ""
    Exit Function
End If
If F2 = "" Then F2 = F1
If F3 = "" Then F3 = F1
If D2 = "" Then D2 = D1
If D3 = "" Then D3 = D1
P = swords(Int((D - Int(D)) * 100), D1, D2, D3)
N = Format(Str(D), "000000000000")
P1 = swords(Mid(N, 10, 3), F1, F2, F3)
P2 = swords(Mid(N, 7, 3), "ألف", "ألفان", "آلاف")
P3 = swords(Mid(N, 4, 3), "مليون", "مليونان", "ملايين")
P4 = swords(Mid(N, 1, 3), "مليار", "ملياران", "مليارات")

If P4 = "" Or P1 + P2 + P3 = "" Then w3 = "" Else w3 = " و "
If P3 = "" Or P1 + P2 = "" Then w2 = "" Else w2 = " و "
If P2 = "" Or P1 = "" Then w1 = "" Else w1 = " و "
If P1 = "" Then P1 = " " + F1
If P = "" Then w = "" Else w = " و "
words = "فقط " + P4 + w3 + P3 + w2 + P2 + w1 + P1 + w + P + " لاغير"
End Function
Function swords(N, U1, U2, U3 As String) As String
 Dim S(1 To 3), w1, w2, F, A(2, 9) As String
 A(0, 0) = ""
 A(0, 1) = "واحد"
 A(0, 2) = "إثنان"
 A(0, 3) = "ثلاثة"
 A(0, 4) = "أربعة"
 A(0, 5) = "خمسة"
 A(0, 6) = "ستة"
 A(0, 7) = "سبعة"
 A(0, 8) = "ثمانية"
 A(0, 9) = "تسعة"
 A(1, 0) = ""
 A(1, 1) = "عشر"
 A(1, 2) = "عشرون"
 A(1, 3) = "ثلاثون"
 A(1, 4) = "أربعون"
 A(1, 5) = "خمسون"
 A(1, 6) = "ستون"
 A(1, 7) = "سبعون"
 A(1, 8) = "ثمانون"
 A(1, 9) = "تسعون"
 A(2, 0) = ""
 A(2, 1) = "مائة"
 A(2, 2) = "مائتان"
 A(2, 3) = "ثلاثمائة"
 A(2, 4) = "أربعمائة"
 A(2, 5) = "خمسمائة"
 A(2, 6) = "ستمائة"
 A(2, 7) = "سبعمائة"
 A(2, 8) = "ثمانمائة"
 A(2, 9) = "تسعمائة"
 Select Case Val(N)
    Case 1
        swords = U1
        Exit Function
    Case 2
        swords = U2
        Exit Function
    Case 0
        swords = ""
        Exit Function
 End Select
 N = Format(N, "000")
 S(1) = Val(Mid(N, 3, 1))
 S(2) = Val(Mid(N, 2, 1))
 S(3) = Val(Mid(N, 1, 1))
 If S(2) = 0 Or S(1) = 0 Then w2 = "" Else w2 = " و "
 If S(3) = 0 Or Val(Mid(N, 2, 2)) = 0 Then w1 = "" Else w1 = " و "
 If S(2) = 1 Then
    A(0, 1) = "أحد "
    A(0, 2) = "إثنا "
    w2 = " "
 End If
 Select Case Val(Mid(N, 2, 2))
    Case 0
        A(2, 2) = "مائتا "
        F = U1
    Case 3 To 10
        F = U3
    Case 1, 2, Is > 10
        F = U1
 End Select
 swords = A(2, S(3)) + w1 + A(0, S(1)) + w2 + A(1, S(2)) + " " + F
End Function

طيب

أرفق لك ملف اكسل يحوي شيفرة تفقيط

اضغط Alt+F11 لعرض الشيفرة

هو كان للريال لكنني حولته لليرة

الريال مذكر و الليرة مؤنث :-)

Nums.zip