تحويل الارقام الى حروف (ثلاث خانات)

هل ينفع هذا؟

Dim Result3, ResultAll As String

Public Function NumToWrite3(Num As Integer) As String
    ' this little function convert the number which consists of three digits convert it to
    ' writable number
    Result3 = ""
    A3 = Num  100: Num = Num Mod 100
    A2 = Num  10: Num = Num Mod 10
    A1 = Num
    Three (A3)
    If (A3 <> 0) And ((A1 <> 0) Or (A2 <> 0)) Then Result3 = Result3 + "و"
    If (Not (((A2 = 0) And (A1 <> 0)) Or ((A2 = 1) And (A1 = 0)))) Then
    One (A1): If ((A1 <> 0) And (A2 <> 1)) Then Result3 = Result3 + "و"
    Two (A2)
    End If
    If ((A2 = 0) And (A1 <> 0)) Then
    SpecialOne (A1)
    Two (A2)
    End If
    If ((A2 = 1) And (A1 = 0)) Then
    Result3 = Result3 + "عشرة "
    End If
    NumToWrite3 = Result3
End Function

Public Sub One(A1 As Byte)
    ' يقرر هذا الإجراء القيمة النصية التي سوف تحل محل الآحاد
    Select Case A1
        Case 0
        Result3 = Result3
        Case 1
        Result3 = Result3 + "إحدى "
        Case 2
        Result3 = Result3 + "اثنا "
        Case 3
        Result3 = Result3 + "ثلاث "
        Case 4
        Result3 = Result3 + "أربع "
        Case 5
        Result3 = Result3 + "خمسة "
        Case 6
        Result3 = Result3 + "ست "
        Case 7
        Result3 = Result3 + "سبع "
        Case 8
        Result3 = Result3 + "ثمانية "
        Case 9
        Result3 = Result3 + "تسع "
    End Select
End Sub

Public Sub Two(A2 As Byte)
    ' يقرر هذا الإجراء القيمة النصية التي سوف تحل محل منزلة العشرات
    Select Case A2
        Case 0
        Result3 = Result3
        Case 1
        Result3 = Result3 + "عشر "
        Case 2
        Result3 = Result3 + "عشرون "
        Case 3
        Result3 = Result3 + "ثلاثون "
        Case 4
        Result3 = Result3 + "أربعون "
        Case 5
        Result3 = Result3 + "خمسون "
        Case 6
        Result3 = Result3 + "ستون "
        Case 7
        Result3 = Result3 + "سبعون "
        Case 8
        Result3 = Result3 + "ثمانون "
        Case 9
        Result3 = Result3 + "تسعون "
    End Select
End Sub

Public Sub Three(A3 As Byte)
    '  يقرر هذا الإجراء القيمة النصية التي سوف تحل محل منزلة المئات
    Select Case A3
        Case 0
        Result3 = Result3
        Case 1
        Result3 = Result3 + "مئة "
        Case 2
        Result3 = Result3 + "مئتان "
        Case 3
        Result3 = Result3 + "ثلاثمئة "
        Case 4
        Result3 = Result3 + "أربعمئة "
        Case 5
        Result3 = Result3 + "خمسمئة "
        Case 6
        Result3 = Result3 + "ستمئة "
        Case 7
        Result3 = Result3 + "سبعمئة "
        Case 8
        Result3 = Result3 + "ثمانمئة "
        Case 9
        Result3 = Result3 + "تسعمئة "
    End Select
End Sub

Public Sub SpecialOne(A1 As Byte)
    ' هذا الإجراء يشبه الإجراء القبل قبل سابق لكنه يعمل فقط في ظروف خاصة
    Select Case A1
        Case 0
        Result3 = Result3
        Case 1
        Result3 = Result3 + "واحد "
        Case 2
        Result3 = Result3 + "اثنين "
        Case 3
        Result3 = Result3 + "ثلاثة "
        Case 4
        Result3 = Result3 + "أربعة "
        Case 5
        Result3 = Result3 + "خمسة "
        Case 6
        Result3 = Result3 + "ستة "
        Case 7
        Result3 = Result3 + "سبعة "
        Case 8
        Result3 = Result3 + "ثمانية "
        Case 9
        Result3 = Result3 + "تسعة "
    End Select
End Sub

Public Function Fkt(Num As Currency) As String
    ' we will divided the whole number to five Groups and every set consist of
    ' three numbers and this Groups stores in a one dimension set called "Groups(6)"

    If Num = 0 Then
        Fkt = "صفر ل.س لا غير"
        Exit Function
    End If
    ResultAll = ""
    Dim strNum, Space, Part As String
    Dim Groups(5) As Integer
    Dim I, J As Integer
    Dim Test As Boolean

    'the following seven lines contains before comma number
    'if you are not familiar with it please delete them
    'and then delete the end if statement in the end of this sub
    'please note that 1000 is resambling the before comma digits
    Dim MsbNum As String
    Dim LsbNum As String
    If Num <> Fix(Num) Then
        MsbNum = Fkt(Fix(Num))
        LsbNum = Fkt((Num - Fix(Num)) * 1000)
        Fkt = MsbNum + "------------" + LsbNum
    Else
        strNum = Str(Num)
        Space = "                                                                             "
        strNum = Space + strNum
        strNum = Right(strNum, (Len(strNum)  3) * 3)
        For I = 1 To 5
            Groups(I) = Val(Right(strNum, 3))
            strNum = Left(strNum, Len(strNum) - 3)
        Next
        For I = 5 To 1 Step -1
            Dl = Groups(I)
            Part = NumToWrite3(Groups(I))
            If (((Part = "واحد ") Or (Part = "اثنين ")) And (I <> 1)) Then
            Part = ""
            End If
            ResultAll = ResultAll + Part
            Test = False
            Select Case I
                Case 5
                Add5 (Dl)
                Case 4
                Add4 (Dl)
                Case 3
                Add3 (Dl)
                Case 2
                Add2 (Dl)
                Case 1
                Add1 (Dl)
            End Select
            For J = 1 To I - 1
            If Groups(J) <> 0 Then Test = True
            Next
            If (Test And (Dl <> 0)) Then ResultAll = ResultAll + "و"
        Next I
        Fkt = ResultAll
    End If
End Function

Public Sub Add5(Num As Integer)
    Select Case Num
        Case 1
        ResultAll = ResultAll + "ترليون "
        Case 2
        ResultAll = ResultAll + "ترليونين "
        Case 3 To 10
        ResultAll = ResultAll + "تريليونات "
        Case Is > 10
        ResultAll = ResultAll + "ترليون "
    End Select
End Sub

Public Sub Add4(Num As Integer)
    Select Case Num
        Case 1
        ResultAll = ResultAll + "مليار "
        Case 2
        ResultAll = ResultAll + "مليارين "
        Case 3 To 10
        ResultAll = ResultAll + "مليارات "
        Case Is > 10
        ResultAll = ResultAll + "مليار "
    End Select
End Sub

Public Sub Add3(Num As Integer)
    Select Case Num
        Case 1
        ResultAll = ResultAll + "مليون "
        Case 2
        ResultAll = ResultAll + "مليونين "
        Case 3 To 10
        ResultAll = ResultAll + "ملايين "
        Case Is > 10
        ResultAll = ResultAll + "مليون "
    End Select
End Sub

Public Sub Add2(Num As Integer)
    Select Case Num
        Case 1
        ResultAll = ResultAll + "ألف "
        Case 2
        ResultAll = ResultAll + "ألفان "
        Case 3 To 10
        ResultAll = ResultAll + "آلاف "
        Case Is > 10
        ResultAll = ResultAll + "ألف "
    End Select
End Sub
Public Sub Add1(Num As Integer)
    ResultAll = ResultAll + " ل.س لا غير "
End Sub

حاول استخدام البحث لأن هذا الموضع طرق حتى مللنا منه .

http://arabteam.nicmatic.com/vb/showthread...%DA%D4%D1%ED%E4

ولك تحياتي