تبديل فرمتهاي مالي به حروف

[taheri-ali]

سلام
من تو بانك اطلاعاتي يه برنامه يه فيلد دارم كه مقدار اون درامد رو نشون مي ده مثلاً:000/000/2 تومان حالا چطوري مي شه كاري كرد كه اين عدد به صورت حرفي نوشته بشه؟يعني : بيست ميليون ريال؟

[AmirAmiri]

بفرما:



Module Module_Tabdil
Dim strYekan() As String = {"صفر", "يک", "دو", "سه", "چهار", "پنج", "شش", "هفت", "هشت", "نه", "ده", "يازده", "دوازده", "سيزده", "چهارده", "پانزده", "شانزده", "هفده", "هجده", "نوزده"}
Dim strDahgan() As String = {"", "ده", "بيست", "سي", "چهل", "پنجاه", "شصت", "هفتاد", "هشتاد", "نود"}
Dim strSadgan() As String = {"", "يکصد", "دويست", "سيصد", "چهارصد", "پانصد", "ششصد", "هفتصد", "هشتصد", "نهصد"}
Dim strHoroofAshar() As String = {"", " دهم", " صدم", " هزام", " ده هزارم", " صد هزارم", " ميليونم", " ده ميليونم", " صد ميليونم", " ميلياردم", " ده ميلياردم", " صد ميلياردم", " تريليونم", " ده تريليونم", " صد تريليونم", " تريلياردم", " ده تريلياردم", " صد تريلياردم", " بيليونم", " ده بيليونم", " صد بيليونم", " بيلياردم", " ده بيلياردم", " صد بيلياردم"}
Const va = " و "

Public Function Horoof(ByVal strAdad As String) As String
Dim intAshar As Integer = InStr(strAdad, "."), intTedadAshar As Integer = Len(strAdad) - intAshar
Dim strAns As String, strLeft As String, strRight As String
If intAshar > 0 Then
strLeft = Tabdil(Left(strAdad, intAshar - 1))
strRight = Tabdil(Right(strAdad, Len(strAdad) - intAshar))
strAns = IIf(Val(Left(strAdad, intAshar - 1)) = 0, "", strLeft & " مميز ") & strRight
If intTedadAshar < 24 Then strAns = strAns & strHoroofAshar(intTedadAshar)
Else
strAns = Tabdil(strAdad)
End If
Return strAns
End Function

Private Function Tabdil(ByVal strAadad As String) As String
Dim strNam() = {" ", " هزار", " ميليون", " ميليارد", " تريليون", " تريليارد", " بيليون", " بيليارد", ""}
Dim intNum(8) As Integer, N As Integer = 0, intLen As Integer = Len(strAadad), strHoroof As String = ""
For i As Integer = 0 To 7
N += 3
Dim LenNum As Integer = Len(Right(strAadad, N)) - (N - 3)
If (intLen >= N - 2) Then intNum(i) = Val(Left(Right(strAadad, N), LenNum))
Next
For i As Integer = LBound(intNum) To UBound(intNum)
If intNum(i) Then strHoroof = IIf(intNum(i + 1) <> 0, va, "") & Tabdil_3Ragham(intNum(i)) & strNam(i) & strHoroof
Next
Return strHoroof
End Function

Private Function Tabdil_3Ragham(ByVal intAdad As Integer) As String
Dim intY As Integer = intAdad Mod 10, intD As Integer = (intAdad Mod 100) \ 10, intS As Integer = intAdad \ 100, strHoroof As String = ""
If intD < 2 Then
strHoroof = IIf(intS = 0, "", strSadgan(intS) & va) & strYekan(intAdad Mod 100)
If (intS > 0 And intD = 0 And intY = 0) Then strHoroof = strSadgan(intS)
Else
strHoroof = IIf(intS = 0, "", strSadgan(intS) & va) & strDahgan(intD) & IIf(intY = 0, "", va & strYekan(intY))
End If
Return strHoroof
End Function
End Module

موفق باشی

[AmirAmiri]

راستی یادم رفت بگم کد بالا اعشار رو نشون میده. در ضمن میتونه تا 48 رقم عدد رو به حروف تبدیل کنه ولی نباید با فرمتی که اون بالا تو سوالتون نوشتید عدد رو بهش بدید چون قاطی میکنه به صورت معمولی عدد بهش بدید.
این کد 24 رقم عدد صحیح و 24 رقم عدد اعشاری رو به حروف تبدیل میکنه.
من نمیدونستم بعد از تریلیون چی داریم برای همین هر چی به ذهنم میرسید نوشتم. لطفا اگه کسی بلده بگه تا تصحیح کنم.
سوال : تا چند بلدی بشماری؟

[ali_md110]

سورس یک برنامه

[touraj]

سلام
من تو بانك اطلاعاتي يه برنامه يه فيلد دارم كه مقدار اون درامد رو نشون مي ده مثلاً:000/000/2 تومان حالا چطوري مي شه كاري كرد كه اين عدد به صورت حرفي نوشته بشه؟يعني : بيست ميليون ريال؟

توی اون سه تا تاپیکی که همیشه بالای همین قسمت هست، کلی برنامه و کد برای تبدیل عدد به حروف فارسی هستش. غیر از اونی که دوستمون گذاشت، این هم هست:


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





-------------------------------------------------------------------------------

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

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



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

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


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

جواب برنامه
هفده و سي و يك دقيقه


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

جواب برنامه
ساعت هفده و سي و يك دقيقه