در به در بدنبال تابع تبدیل اعداد به حروف

اگر کسی تابعی برای تبدیل اعداد به حروف داره اینجا بگذاره که خیلیها مثل من در به در دنبال این تابع هستند، البته من قبلا این تابع را داشتم ولی گمش کردم و حالا هم حوصله نوشتنش رو ندارم.
مثل : 1200000 یک میلیون و دویست هزار ریال

دمتون گرم

سلام
منم دنبال یه همچین چیزی میگیردم!
با تشکر قبلی :wink:

با پاسکال دارم ... بدردتون می خوره؟

آقا سورسش رو بگذار اینجا من براشون تبدیل به Dll میکنم.

منم با paradax تحت داس این کا رو کردم که تا چار رقم رو تبدیل میکرد
ولی باید پیداش کنم

من هم این تابع رو با FoxPro تحت داس نوشتم . خیلی هم خوب کار میکنه .
اگه به درد کسی میخوره میتونم بگذارمش اینجا ...

چقدر طالب داره این کد :shock:
این کد مورد نظر شما عزیزان هست. :wink:

Option Explicit

Private Const hezar = " هزار"

Private Const melun = " میلیون "

Private Const melyard = " میلیارد "

Private Const va = " و "



Public Function heji_adad(ByVal adad As Double) As String

Dim hooroof As String

Dim SS As Integer  'sadgan

Dim hh As Integer   'hezargan

Dim mm As Integer  'melungan

Dim yy As Integer   'melyardgan

Dim STRadad As String

Dim LENadad As Integer



STRadad = Str(Val(Str(adad)))

LENadad = Len(STRadad)



Select Case adad

                Case Is = 0

                                hooroof = "صفر"

                Case 1 To 999

                                   hooroof = Adad_Heji(adad)



                Case 1000 To 999999



                            If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar

                            If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000))



                Case 1000000 To 999999999



                SS = Val(Right$(STRadad, 3))

                 hh = Val(Mid$(STRadad, LENadad - 5, 3))

                 mm = Val(Left$(STRadad, LENadad - 6))



               If (SS = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun

               If (SS = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar

               If (SS <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(SS)

               If (SS <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)



               Case 1000000000 To 999999999999#



                       SS = Val(Right$(STRadad, 3))

                       hh = Val(Mid$(STRadad, LENadad - 5, 3))

                       mm = Val(Mid$(STRadad, LENadad - 8, 3))

                       yy = Val(Left$(STRadad, LENadad - 9))



                            If (SS = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard

                            If (SS = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun

                            If (SS = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar

                            If (SS <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)



                   Case Is > 999999999999#

                               hooroof = "فکر کنم یادت رفت دستت را از روی صفحه کلید برداری "



    End Select

   

   heji_adad = hooroof

End Function



Private Function Adad_Heji(ByVal adad As Integer) As String

        Dim yekan As Byte

        Dim dahgan As Byte

        Dim sadgan As Byte

        Dim behooroof As String



Dim heji(19) As String

Dim heji_dahgan(9) As String

Dim heji_sadgan(9) As String

'-------------------------------

heji(1) = "یک": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج"

heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده"

heji(11) = "یازده": heji(12) = "دوازده": heji(13) = "سیزده": heji(14) = "چهارده": heji(15) = "پانزده"

heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هیجده": heji(19) = "نوزده"

'-------------------------------

heji_dahgan(1) = "ده"

heji_dahgan(2) = "بیست"

heji_dahgan(3) = "سی": heji_dahgan(4) = "چهل": heji_dahgan(5) = "پنجاه"

heji_dahgan(6) = "شصت": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد"

heji_dahgan(9) = "نود"

'------------------------

heji_sadgan(1) = "یکصد": heji_sadgan(2) = "دویست": heji_sadgan(3) = "سیصد"

heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد"

heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد"

'------------------------------------------------------------------------------------------------------------

         yekan = adad Mod 10

        dahgan = adad Mod 100

        sadgan = Int(adad / 100)

'------------------------------------------------------------------------------------------------------------

        If dahgan < 20 Then



                    If (sadgan = 0) Then behooroof = heji(dahgan)

                    If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan)

                    If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan)



        Else

            dahgan = (adad Mod 100) - yekan



                       If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10)

                       If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan)

                       If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10)

                       If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan)



        End If



Adad_Heji = behooroof

End Function

نویسنده : بابک بخشایش
نحوه استفاده :

heji_adad(عدد مورد نظر)

نکته :
ماکزیمم عدد قابل استفاده : 999.999.999.999

چیز دیگه ای خواستید در خدمتم. :wink:

بابا یکم حوصله به خرج بدید چقدر شما ها کم حوصله اید :P :P

Public Function change_mony(ByVal Pol As Variant) As String

Dim P As String, p1 As String

Dim P2 As String, P3 As String

Dim P4 As String, Sk As String

Dim L As Byte

If Pol > 0 Then

          P = Str(Pol)

          Sk = Right(Trim(P), 3)

          p1 = harf(Val(Trim(Sk)))

          p1 = Trim(p1) & " ریال"

          If Len(Trim(P)) > 3 Then

                   Sk = Right(Trim(P), 6)

                   L = Len(Trim(Sk))

                   Sk = Left(Trim(Sk), (L - 3))

                   P2 = harf(Val(Trim(Sk)))

                   P2 = Trim(P2) & " هزار و"

          End If

          If Len(Trim(P)) > 6 Then

                   Sk = Right(Trim(P), 9)

                   L = Len(Trim(Sk))

                   Sk = Left(Trim(Sk), (L - 6))

                   P3 = harf(Val(Trim(Sk)))

                   P3 = Trim(P3) & " میلیون و"

          End If

          If Len(Trim(P)) = 10 Then

                   Sk = Left(Trim(P), 1)

                   P4 = harf(Val(Trim(Sk)))

                   P4 = Trim(P4) & " میلیارد و"

          End If

          change_mony = Trim(P4) & Trim(P3) & Trim(P2) & Trim(p1)

End If

End Function



Private Function harf(mony2 As Long) As String

Dim S As String, s1 As String

Dim s2 As String, s3 As String

S = Trim(Str(mony2))

If Len(Trim(Str(mony2))) = 1 Then S = "00" & Trim(Str(mony2))

If Len(Trim(Str(mony2))) = 2 Then S = "0" & Trim(Str(mony2))

Select Case Left(Trim(S), 1)

       Case 0

             s1 = ""

       Case 1

             s1 = "یکصد"

       Case 2

             s1 = "دویست"

       Case 3

             s1 = "سیصد"

       Case 4

             s1 = "چهارصد"

       Case 5

             s1 = "پانصد"

       Case 6

             s1 = "ششصد"

       Case 7

             s1 = "هفتصد"

       Case 8

             s1 = "هشتصد"

       Case 9

             s1 = "نهصد"

End Select

Select Case Mid(Trim(S), 2, 1)

       Case 0

             s2 = ""

       Case 1

             Select Case Right(Trim(S), 1)

                    Case 0

                         s2 = "ده"

                    Case 1

                         s2 = "یازده"

                    Case 2

                         s2 = "دوازده"

                    Case 3

                         s2 = "سیزده"

                    Case 4

                         s2 = "چهارده"

                    Case 5

                         s2 = "پانزده"

                    Case 6

                         s2 = "شانزده"

                    Case 7

                         s1 = "هفده"

                    Case 8

                         s1 = "هجده"

                    Case 9

                         s1 = "نوزده"

              End Select

       Case 2

             s2 = "بیست"

       Case 3

             s2 = "سی"

       Case 4

             s2 = "چهل"

       Case 5

             s2 = "پنجاه"

       Case 6

             s2 = "شصت"

       Case 7

             s2 = "هفتاد"

       Case 8

             s2 = "هشتاد"

       Case 9

             s2 = "نود"

End Select

If Mid(Trim(S), 2, 1) <> 1 Then

Select Case Right(Trim(S), 1)

       Case 0

             s3 = ""

       Case 1

             s3 = "یک"

       Case 2

             s3 = "دو"

       Case 3

             s3 = "سه"

       Case 4

             s3 = "چهار"

       Case 5

             s3 = "پنج"

       Case 6

             s3 = "شش"

       Case 7

             s3 = "هفت"

       Case 8

             s3 = "هشت"

       Case 9

             s3 = "نه"

End Select

End If

If Trim(s1) <> "" Then s1 = s1 & " و"

If Trim(s2) <> "" Then s2 = s2 & " و"

If Trim(s3) <> "" Then s3 = s3 & " و"

S = s1 & s2 & s3

If Trim(S) <> "" Then harf = Left(Trim(S), (Len(Trim(S)) - 1)) Else harf = ""

End Function

این کد را می توانید تا هر مقدار که دوست دارید افزایش دهید کافیست یکم" کم حوصله " نباشید :mrgreen: :mrgreen:
راستی فانکشن اصلیه Change_mony() می باشد

به قول گلاد جونم برید حالشو ببرید :wink:

از این dll هم میتونید استفاده کنید.
به این صورت که بعد از اضافه کردن به ریسورسها
اینشکلی استفاده کنید.

Dim pt As New PersianTools

MsgBox (pt.DigitToPersianString(12544)&#41  ;

MsgBox (pt.DateToPersian(Now).LongDate&#41  ;

آقای نوربالا ، اگر لطف کنی و سورس این برنامه Dll رو نیز برای استفاده ما روی این سایت بگذارید ، عالیه.

یکبار یه سورس خیلی خوب از تبدیل تاریخ گذاشتی که خیلی به من کمک کرد.

من این کد را با تغییراتی که روی آن انجام دادم ، برای تبدیل عدد به حروف استفاده می کنم.
منبع اصلی این برنامه را از یک مثال برنامه برداشتم.

Function ConvertCurrencyToEnglish(ByVal MyNumber)



'Syntax :

                '=ConvertCurrencyToEnglish([نام فیلدی که باید مبلغ عددی آن بحروف تبدیل شود])

                '=ConvertCurrencyToEnglish([Total]&#41  ;

         Dim Temp

         Dim Dollars, Cents

         Dim DecimalPlace, Count



         ReDim Place(9) As String

         Place(2) = " هزار و "

         Place(3) = " میلیون و "

         Place(4) = " میلیارد و "

         Place(5) = " تریلون و "



         ' Convert MyNumber to a string, trimming extra spaces.

         MyNumber = Trim(str(MyNumber))



         ' Find decimal place.

         DecimalPlace = InStr(MyNumber, ".")



         ' If we find decimal place...

         If DecimalPlace > 0 Then

            ' Convert cents

            Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)

            Cents = ConvertTens(Temp)



            ' Strip off cents from remainder to convert.

            MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

         End If



         Count = 1

         Do While MyNumber <> ""

            ' Convert last 3 digits of MyNumber to English dollars.

            Temp = ConvertHundreds(Right(MyNumber, 3))

            If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars

            If Len(MyNumber) > 3 Then

               ' Remove last 3 converted digits from MyNumber.

               MyNumber = Left(MyNumber, Len(MyNumber) - 3)

            Else

               MyNumber = ""

            End If

            Count = Count + 1

         Loop



         ' Clean up dollars.

         Select Case Dollars

            Case ""

               Dollars = "" '"No Dollars"

            Case "One"

               Dollars = "یک تومان" '"One Dollar"

            Case Else

               Dollars = Dollars & " ریال" 'تومان

         End Select



         ' Clean up cents.

         Select Case Cents

            Case ""

               Cents = "" '" And No Cents"

            Case "One"

               Cents = "یک ریال" '" And One Cent"

            Case Else

               Cents = " و " & Cents & " ریال"

         End Select



         ConvertCurrencyToEnglish = Dollars & Cents

End Function



'تبدیل رقم یکان به معادل حروفی

Private Function ConvertDigit(ByVal MyDigit)

        Select Case Val(MyDigit)

            Case 1: ConvertDigit = "یک"

            Case 2: ConvertDigit = "دو"

            Case 3: ConvertDigit = "سه"

            Case 4: ConvertDigit = "چهار"

            Case 5: ConvertDigit = "پنج"

            Case 6: ConvertDigit = "شش"

            Case 7: ConvertDigit = "هفت"

            Case 8: ConvertDigit = "هشت"

            Case 9: ConvertDigit = "نه"

            Case Else: ConvertDigit = ""

         End Select

         

End Function



Private Function ConvertHundreds(ByVal MyNumber)

    Dim Result As String



         ' Exit if there is nothing to convert.

         If Val(MyNumber) = 0 Then Exit Function



         ' Append leading zeros to number.

         MyNumber = Right("000" & MyNumber, 3)



         ' Do we have a hundreds place digit to convert?

         If Left(MyNumber, 1) <> "0" Then

         ' Result = ConvertDigit(left(MyNumber, 1)) & " صـد "

             Result = Convert100(Left(MyNumber, 1)) & " "

         End If



         ' Do we have a tens place digit to convert?

         If Mid(MyNumber, 2, 1) <> "0" Then

            Result = Result & ConvertTens(Mid(MyNumber, 2))

         Else

            ' If not, then convert the ones place digit.

            Result = Result & ConvertDigit(Mid(MyNumber, 3))

         End If



         ConvertHundreds = Trim(Result)

End Function



Private Function ConvertTens(ByVal MyTens)

    Dim Result As String

         ' Is value between 10 and 19?

         If Val(Left(MyTens, 1)) = 1 Then

            Select Case Val(MyTens)

               Case 10: Result = "ده"

               Case 11: Result = "یازده"

               Case 12: Result = "دوازده"

               Case 13: Result = "سیزده"

               Case 14: Result = "چهارده"

               Case 15: Result = "پانزده"

               Case 16: Result = "شانزده"

               Case 17: Result = "هفده"

               Case 18: Result = "هیجده"

               Case 19: Result = "نوزده"

               Case Else

            End Select

         Else

            ' .. otherwise it's between 20 and 99.

            Select Case Val(Left(MyTens, 1))

               Case 2: Result = "بیست "

               Case 3: Result = "سی "

               Case 4: Result = "چهل "

               Case 5: Result = "پنجاه "

               Case 6: Result = "شصت "

               Case 7: Result = "هفتاد "

               Case 8: Result = "هشتاد "

               Case 9: Result = "نود "

               Case Else

            End Select

            ' Convert ones place digit.

            Result = Result & ConvertDigit(Right(MyTens, 1))

         End If

         ConvertTens = Result

End Function

       

'تبدیل رقم صدگان به معادل حروفی

' 100 between 900?

Public Function Convert100(ByVal MyDigit1)

       Select Case Val(MyDigit1)

            Case 1: Convert100 = "یکصد"

            Case 2: Convert100 = "دویست"

            Case 3: Convert100 = "سیصد"

            Case 4: Convert100 = "چهارصد"

            Case 5: Convert100 = "پانصد"

            Case 6: Convert100 = "ششصد"

            Case 7: Convert100 = "هفتصد"

            Case 8: Convert100 = "هشتصد"

            Case 9: Convert100 = "نهصد"

            Case Else: Convert100 = ""

         End Select

End Function

شما می توانید این برنامه را در یک ماژول ذخیره کنید و هرکجا خواستید اسم ماژول را فراخوانی کنید.

VBstar

سلام!
توی اینجور جایگذاری ها از select case استفاده نکنید کند میشه! از آریه ها استفاده کنید

علت کندی چیه و مزیت آرایه در چی هست ؟؟؟ :)

آقای مسعود غیبی خیلی خوب بود دستت درد نکنه
از دیگر عزیزان نیز کمال تشکر را دارم
:lol: :lol: :lol:

آقای غیبی دست مریزاد !
منم به این کد خیلی احتیاج داشتم . :wink:

ببخشید این کدها را کجا بنویسیم ؟ :mrgreen: :mrgreen: :mrgreen:

روی فرممون چی طراجی کنیم :cry:

اینو قبلا هم گداشته بودم اما یه بار دیگه عیبی نداره.

'This Function convert Numbers To Text 

Public Function NoToText(eNo As Double, _ 

                   Optional isCounter As Boolean = False) As String 



Dim tStr, tNo, eNumber As String 

Dim i, j, k As Double 

Dim m_isNeg As Boolean 



    'This Number is Negative Or Positive? 

    m_isNeg = IIf(Sgn(eNo) = -1, True, False) 



    

    If eNo = 0 Then 'This Number is Zero; Don't Continue anymore 

        NoToText = IIf(isCounter, "صفرم ", "صفر ") 

        Exit Function 

    'NOTE: We can delete Following 3 Lines of code to have "یکم" instead of "اول" 

    'TODO: we can Make a new optional Argument to ask this from user 

    ElseIf (eNo = 1) And isCounter And (Not m_isNeg) Then 

        NoToText = "اول " 

        Exit Function 

    End If 



    'TODO: Add Support for decimal Numbers 

    'convert input to Absolute value w/o Thousand separators, as a String 

    eNumber = Abs(eNo) 



    'Add Some Extra Zero at the begining of String 

    eNumber = Choose(Len(eNumber) Mod 3, "00", "0") & eNumber 



    tStr = "" 

    k = Len(eNumber) / 3 



    For i = 1 To Len(eNumber) Step 3 

    ' 

        tNo = Mid(eNumber, i, 3) 

        If tNo <> "000" Then 

            

            'Convert The First Digit Of Group --> `5`12 

            tStr = tStr & _ 

            DigitToText(Mid(tNo, 1, 1) & "00") 



            'If the Second Digit is <1> Then We Have a number between _ 

             Ten and Nineteen; 

            If Mid(tNo, 2, 1) = "1" Then '--> 5`12` 

                tStr = tStr & _ 

                DigitToText(Mid(tNo, 2, 2)) 

            Else 'elsewhere, do normal method 

                tStr = tStr & _ 

                DigitToText(Mid(tNo, 2, 1) & "0")        '--> 5`2`6 

                tStr = tStr & _ 

                DigitToText(Mid(tNo, 3, 1)) 

            End If 

            'if u know greater values then >>>>>>>>>>>>>>>>>>>>just Add it below 

            tStr = tStr & Choose(k, "", "هزار ", "میلیون ", "میلیارد ", "تریلیون ") '<<< here before `)` 

        End If 

        k = k - 1 

    

    Next i 



    'If in Counting Mode then add appropriate Suffixes to end of string 

    If isCounter Then 

        If Right(eNumber, 1) = "3" Then 

            tStr = Left(tStr, Len(tStr) - 2) & "وم" 'is `سهم` true?! ;) 

        ElseIf Right(eNumber, 2) = "30" Then 

            tStr = Left(tStr, Len(tStr) - 1) & "‌ام" 'and u know `سیم` is wrong! ;) 

        Else 

            tStr = RTrim(tStr) & "م" 'make countable strings like `دوازدهم`,`پنجم`, etc... 

        End If 

    End If 



    'This is Result!! ;) 

    NoToText = IIf(m_isNeg, "منفی ", "") & Mid(tStr, 3) 



End Function 





Private Function DigitToText(eNo As String) 

Dim tStr As String 

Dim tDbl As Double 



If eNo = "" Or eNo = "0" Or eNo = "00" Or eNo = "000" Then 

    DigitToText = "" 

    Exit Function 

End If 



tDbl = Val(eNo) 

Select Case tDbl 

    Case Is >= 1000 

        tStr = "" 

    Case Is >= 900 

        tStr = "نهصد" 

    Case Is >= 800 

        tStr = "هشتصد" 

    Case Is >= 700 

        tStr = "هفتصد" 

    Case Is >= 600 

        tStr = "ششصد" 

    Case Is >= 500 

        tStr = "پانصد" 

    Case Is >= 400 

        tStr = "چهارصد" 

    Case Is >= 300 

        tStr = "سیصد" 

    Case Is >= 200 

        tStr = "دویست" 

    Case Is >= 100 

        tStr = "صد" 

    Case Is >= 90 

        tStr = "نود" 

    Case Is >= 80 

        tStr = "هشتاد" 

    Case Is >= 70 

        tStr = "هفتاد" 

    Case Is >= 60 

        tStr = "شصت" 

    Case Is >= 50 

        tStr = "پنجاه" 

    Case Is >= 40 

        tStr = "چهل" 

    Case Is >= 30 

        tStr = "سی" 

    Case Is >= 20 

        tStr = "بیست" 

    Case Is >= 19 

        tStr = "نوزده" 

    Case Is >= 18 

        tStr = "هیجده" 

    Case Is >= 17 

        tStr = "هفده" 

    Case Is >= 16 

        tStr = "شانزده" 

    Case Is >= 15 

        tStr = "پانزده" 

    Case Is >= 14 

        tStr = "چهارده" 

    Case Is >= 13 

        tStr = "سیزده" 

    Case Is >= 12 

        tStr = "دوازده" 

    Case Is >= 11 

        tStr = "یازده" 

    Case Is >= 10 

        tStr = "ده" 

    Case Is >= 9 

        tStr = "نه" 

    Case Is >= 8 

        tStr = "هشت" 

    Case Is >= 7 

        tStr = "هفت" 

    Case Is >= 6 

        tStr = "شش" 

    Case Is >= 5 

        tStr = "پنج" 

    Case Is >= 4 

        tStr = "چهار" 

    Case Is >= 3 

        tStr = "سه" 

    Case Is >= 2 

        tStr = "دو" 

    Case Is >= 1 

        tStr = "یک" 

    Case Is >= 0 

        tStr = "" 

End Select 

    DigitToText = "و " + tStr + " " 

End Function 



'ALL RIGHTS RESERVED BY: Mohammad Shiran

و این هم تابع دومی برای تبدیل اعداد اعشاری

Function DecimalToText(eNo As Double, _ 

                       Optional DecStyle As Boolean = False _ 

                                                  ) As String 

                        

    Dim eFixed As String, eDecimal As String 

    Dim sResult As String 

    

    'return fixed value of given number as string 

    eFixed = Fix(eNo) 

    

    'if this number has some decimals 

    If (Len(CStr(eNo)) - Len(eFixed)) Then 

        'get it as a string, Example: return `125` for `12.125` 

        eDecimal = Mid(CStr(eNo), Len(eFixed) + 2) 

        'return fixed part as text 

        sResult = NoToText(CDbl(eFixed)) & IIf(DecStyle, "و ", "ممیز ") 

        'if decimal section is `5` then use `نیم` Instead of `پنج دهم` 

        'this is optional, u can remove it if u like 

        If eDecimal = 5 Then 

            sResult = sResult & "نیم" 

        Else 

            'convert the decimal part of number to text 

            sResult = sResult & _ 

                      NoToText(CDbl(eDecimal)) 

            'add extra suffix at end of string, depending to number of decimal places 

            sResult = sResult & _ 

                      Choose(Len(eDecimal), "دهم", "صدم", _ 

                                            "هزارم", "ده هزارم", _ 

                                            "صد هزارم", "میلیونیم") ', _ 

                                             .... 

        End If 

            

    Else 

        'if this number is originally an integer then convert it using normal method 

        sResult = NoToText(eNo) 

    End If 

    'return the result. ;) 

    DecimalToText = sResult 

    

End Function

این دو تا تابع میتونن خروجی هایی بصورت زیر بدن:
0.2=دو دهم
1.35= یک ممیز سی و پنج صدم
2.5=دو و نیم/دو ممیز پنج دهم
0.002= دو هزارم
120001= صد و بیست هزار و یک
یا مثلا: اول، دوم، سوم و ...

مثال عملی:

msgbox DecimalToText(2.5,false)

'='دو ممیز پنج دهم'