ماژول تبدیل اعداد اعشاری

[Ali_Fallah]

دوستان عزیز برنامه (ماژول) دارید که بتونه اعداد اعشاری رو هم به حروف تبدیل کنه
البته نه اینایی که قبلاً آپلود شده
چون به نظر به درستی کار نمیکنند. لطفاً چگونگی بکار گیری رو هم توضیح بدین.
متشکرم:تشویق:

[شاپرک]

این چی امتحان کردی؟


یه مثال خیلی خوب با امکان خواندن اعداد منفی و اعشار و خواندن تاریخ و ساعت !!!!!!!!!!
سلام

ایم نمونه برنامه تا محدوده تریلیون (999,999,999,999,999) رو می خونه
تازه اگه بیشتر از تریلیونو اسماشو بدونین به راحتی میشه اضافه کرد
یعنی اصلا محدودیت نداره

اعداد منفی و اعشار دار رو هم می خونه
دو تا تابع هم واسش نوشتم که تاریخ و ساعت رو هم می خونه

دیگه چی می خواهید ؟؟؟؟؟؟؟؟؟؟


اینم مثال اعداد
Text1 = ReadNum("-45632.25")

و جواب برنامه
منفی چهل و پنج هزار و ششصد و سی و دو و بیست و پنج صدم



مثال تاریخ
Text1 = ReadTarikh(84, 6, 25)

جواب برنامه
بیست و پنجم شهریور ماه سال هشتاد و چهار


مثال ساعت 1
Text1 = ReadClock(17, 31, 0)

جواب برنامه
هفده و سی و یک دقیقه


مثال ساعت 2
Text1 = ReadClock(17, 31, 1)

جواب برنامه
ساعت هفده و سی و یک دقیقه







Option Explicit

Public Function ReadNum(ByVal Number As Currency) As String

On Local Error Resume Next

Dim Adad1000(4) As String, Ashar(11) As String, Temp As String, x As String
Dim t As Currency, s As String, i As Integer
Dim Negative As Byte, AsharRead As String

Adad1000(1) = "هزار"
Adad1000(2) = "میلیون"
Adad1000(3) = "میلیارد"
Adad1000(4) = "تریلیون"

Ashar(1) = "دهم"
Ashar(2) = "صدم"
Ashar(3) = "هزارم"
Ashar(4) = "ده هزارم"
Ashar(5) = "صد هزارم"
Ashar(6) = "میلیونیوم"
Ashar(7) = "ده میلیونیوم"
Ashar(8) = "صد میلیونیوم"
Ashar(9) = "میلیاردیم"
Ashar(10) = "ده میلیاردیم"
Ashar(11) = "صد میلیاردیم"

If Number < 0 Then
Negative = 1
Number = Abs(Number)
End If

If Fix(Number) < Number Then
Dim A As Currency, Index As Integer
A = Number - Fix(Number)

AsharRead = Mid$(Str$(A), InStr(Str$(A), ".") + 1)

If Len(AsharRead) > 11 Then
AsharRead = Left$(AsharRead, 11)
Index = 11
Else
Index = Len(AsharRead)
End If

If Fix(Number) > 0 Then
AsharRead = " و " & ReadNum(Val(AsharRead)) & " " & Ashar(Index)
Else
AsharRead = ReadNum(Val(AsharRead)) & " " & Ashar(Index)
End If

AsharRead = ReplaceAll(AsharRead, "پنج دهم", "نیم")

End If

Number = Fix(Number)
If Number < 1000 Then

If Negative Then
ReadNum = "منفی " & Read3Digit(Number) & AsharRead
Else
ReadNum = Read3Digit(Number) & AsharRead
End If

Exit Function

End If

Temp = CStr(Number)
x = Right$(Temp, 3)

While x <> ""

t = Val(x)

If t Then

If Len(s) Then s = " و " & s
s = Adad1000(i) & s

If Len(s) Then s = " " & s
s = Read3Digit(t) & s
End If

If Len(Temp) > 2 Then
Temp = Left$(Temp, Len(Temp) - 3)
Else
Temp = ""
End If

If Temp = " " Then Temp = ""

x = Right$(Temp, 3)
i = i + 1

Wend

s = s & AsharRead

If Negative Then s = "منفی " & s

ReplaceAll s, " ", " "

ReadNum = s

End Function

Public Function Read3Digit(Number) As String

On Local Error Resume Next

Dim Adad(20) As String
Dim Adad10(9) As String
Dim Adad100(9) As String
Dim Yekan As Currency, Dahgan As Currency, Sadgan As Currency, Temp As Currency
Dim s As String

Adad(0) = "صفر"
Adad(1) = "یک"
Adad(2) = "دو"
Adad(3) = "سه"
Adad(4) = "چهار"
Adad(5) = "پنج"
Adad(6) = "شش"
Adad(7) = "هفت"
Adad(8) = "هشت"
Adad(9) = "نه"
Adad(10) = "ده"
Adad(11) = "یازده"
Adad(12) = "دوازده"
Adad(13) = "سیزده"
Adad(14) = "چهارده"
Adad(15) = "پانزده"
Adad(16) = "شانزده"
Adad(17) = "هفده"
Adad(18) = "هجده"
Adad(19) = "نوزده"

Adad10(0) = "ده"
Adad10(1) = "بیست"
Adad10(2) = "سی"
Adad10(3) = "چهل"
Adad10(4) = "پنجاه"
Adad10(5) = "شصت"
Adad10(6) = "هفتاد"
Adad10(7) = "هشتاد"
Adad10(8) = "نود"
Adad100(0) = "صد"
Adad100(1) = "دویست"
Adad100(2) = "سیصد"
Adad100(3) = "چهار صد"
Adad100(4) = "پانصد"
Adad100(5) = "ششصد"
Adad100(6) = "هفتصد"
Adad100(7) = "هشتصد"
Adad100(8) = "نهصد"

If Number > 999 Then

Read3Digit = ""
Exit Function

End If

Sadgan = Int(Number / 100)
Temp = Number Mod 100
Dahgan = Int(Temp / 10)
Yekan = Temp Mod 10

Temp = Dahgan * 10 + Yekan

If Temp < 20 Then

If Temp Then

s = s + Adad(Temp)

If Sadgan Then s = " و " & s

End If

If Sadgan Then s = Adad100(Sadgan - 1) & s

Else

If Yekan Then

s = s + Adad(Yekan)

If Dahgan Then s = " و " & s

End If

If Dahgan Then

s = Adad10(Dahgan - 1) & s

If Sadgan Then s = " و " & s

End If

If Sadgan Then s = Adad100(Sadgan - 1) & s

End If

Read3Digit = s

End Function

Public Function ReadTarikh(yy As Integer, Mm As Integer, Dd As Integer) As String

On Local Error Resume Next

Dim DayStr As String, MonthStr As String, YearStr As String, f As Integer
Dim DateStr(2) As String
Dim MonthName(12) As String

MonthName(1) = "فروردین"
MonthName(2) = "اردیبهشت"
MonthName(3) = "خرداد"
MonthName(4) = "تیر"
MonthName(5) = "مرداد"
MonthName(6) = "شهریور"
MonthName(7) = "مهر"
MonthName(8) = "آبان"
MonthName(9) = "آذر"
MonthName(10) = "دی"
MonthName(11) = "بهمن"
MonthName(12) = "اسفند"

DateStr(0) = " روز "
DateStr(1) = " ماه "
DateStr(2) = " سال "

DayStr = ""
MonthStr = ""
YearStr = ""

If Dd <> 0 Then DayStr = ReadNum(Dd) + "م "

f = InStr(DayStr, "سهم")

If f Then DayStr = Left$(DayStr, f - 1) + "سوم" + Mid$(DayStr, f + 3)

If Mm <> 0 Then MonthStr = MonthName(Mm) + DateStr(1)

If yy <> 0 Then YearStr = DateStr(2) + ReadNum(yy)

ReadTarikh = DayStr + MonthStr + YearStr
Dim i%

For i = 1 To 3
ReadTarikh = ReplaceAll(ReadTarikh, " ", " ")

Next

End Function

Function ReadClock(hh As Byte, Mm As Byte, Optional AddSaatWord As Byte = 1) As String

On Local Error Resume Next

Dim MinuteStr As String, HourStr As String

Dim ZamanName(2) As String

ZamanName(1) = " ساعت "
ZamanName(2) = " دقیقه "

MinuteStr = ""
HourStr = ""

If Mm <> 0 Then MinuteStr = ReadNum$(Mm) + ZamanName(2)

If hh > 0 Then
If AddSaatWord Then HourStr = ZamanName(1)
HourStr = HourStr + ReadNum$(hh)
ElseIf hh = 0 Then
If AddSaatWord Then HourStr = ZamanName(1)
HourStr = HourStr + " صفر "
End If

If Mm <> 0 And hh >= 0 Then HourStr = HourStr + " و "
ReadClock = ReplaceAll(HourStr + MinuteStr, " ", " ")

End Function

Public Function ReplaceAll(ByVal SourceString As String, ReplaceThis As String, Optional WithThis As String = "", Optional Level As Integer = 10) As String

On Local Error Resume Next

Dim Temp() As String, i%

For i = 0 To Level
Temp = Split(SourceString, ReplaceThis)
ReplaceAll = Join(Temp, WithThis)
SourceString = Join(Temp, WithThis)
Next

ReplaceAll = SourceString

End Function

منبع :
http://barnamenevis.org/forum/showthread.php?t=15209&page=15

[Ali_Fallah]

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

Text1 = ReadNum("1205")

[Ali_Fallah]

دوستان عزیز کدهای دیگری در اختیار ندارند...