نوشتن معادل فارسی اعداد اعشاری

[انگوران]

دوستان سلام - یکی از دوستان قبلاً این سئوال رو مطرح کرده بود که چطوری می شه معادل فارسی اعداد اعشاری رو نوشت ( مثلاً عدد 19.5 ، نوزده و نیم نوشته بشه ) . متاسفانه هر چی دنبالش می گردم پیداش نمی کنم اگه از دوستان کسی لینک یا ماژولش رو داره لطف کنه دوباره برامون بذاره .

[شاپرک]

http://barnamenevis.org/forum/showthread.php?t=51987

[انگوران]

ضمن تشکر فکر می کنم کدی که آقای فضائلی پیوست کردن مد نظر باشه که من نتونستم استفاده کنم . در صورت امکان طریقه استفاده اونو هم بفرمائید .
من این کار رو کردم پس از کپی کد در یه ماجول داخل یه تکست باکس نوشتم که ارور می گیره
=DecimalToText(19.5)

[شاپرک]

'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)
'='دو ممیز پنج دهم'

__________________
اینم لینکش :
http://barnamenevis.org/forum/showthread.php?t=5007&page=2&highlight=%CA%C8%CF%ED%E1+%C7%DA%D4%C7%D1%ED

[انگوران]

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

[انگوران]

احتمالاً از دید اساتید مخفی مونده

[samaneh_h]

حلهههههههههههههههههههه