taheri-ali
شنبه 21 اردیبهشت 1387, 13:36 عصر
سلام
من تو بانك اطلاعاتي يه برنامه يه فيلد دارم كه مقدار اون درامد رو نشون مي ده مثلاً:000/000/2 تومان حالا چطوري مي شه كاري كرد كه اين عدد به صورت حرفي نوشته بشه؟يعني : بيست ميليون ريال؟
AmirAmiri
شنبه 21 اردیبهشت 1387, 14:05 عصر
بفرما:
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
شنبه 21 اردیبهشت 1387, 14:09 عصر
راستی یادم رفت بگم کد بالا اعشار رو نشون میده. در ضمن میتونه تا 48 رقم عدد رو به حروف تبدیل کنه ولی نباید با فرمتی که اون بالا تو سوالتون نوشتید عدد رو بهش بدید چون قاطی میکنه به صورت معمولی عدد بهش بدید.
این کد 24 رقم عدد صحیح و 24 رقم عدد اعشاری رو به حروف تبدیل میکنه.
من نمیدونستم بعد از تریلیون چی داریم برای همین هر چی به ذهنم میرسید نوشتم. لطفا اگه کسی بلده بگه تا تصحیح کنم.
سوال : تا چند بلدی بشماری؟
ali_md110
سه شنبه 24 اردیبهشت 1387, 03:09 صبح
سورس یک برنامه
touraj
سه شنبه 24 اردیبهشت 1387, 11:35 صبح
سلام
من تو بانك اطلاعاتي يه برنامه يه فيلد دارم كه مقدار اون درامد رو نشون مي ده مثلاً: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)
جواب برنامه
ساعت هفده و سي و يك دقيقه
vBulletin® v4.2.5, Copyright ©2000-1403, Jelsoft Enterprises Ltd.