View Full Version : تبدیل عدد به حروف
Web Matrix Pro
شنبه 29 مهر 1385, 15:58 عصر
سلام
من یه تابع می خوام که عدد رو به حروف تبدیل کنه تا ا میلیاد هم باشه خوبه
با تشکر
rezaTavak
شنبه 29 مهر 1385, 23:22 عصر
سلام
قبلا یکی بود فکر کنم سایت update شده پاک شده:
FUNCTION StringRial
LPARAMETERS tnRial
LOCAL lcOutput,lcRial,lnIndex, lnLoop, lcTemp
#DEFINE WA 'æ'
lcRial = ALLTRIM(STR(tnRial))
lcOutput = ''
lnLoop = LEN(lcRial)
FOR lnIndex = 1 TO lnLoop STEP 3
lcTemp = num100(RIGHT(lcRial,3))
lcOutPut = IIF(NOT EMPTY(lcTemp),lcTemp+HMMBT(lnIndex)+IIF(NOT EMPTY(lcOutput),WA,''),'') + lcOutPut
lcRial = LEFT(lcRial,LEN(lcRial)-3)
NEXT
IF EMPTY(lcOutput)
lcOutput = 'ÕÝÑ'
ENDIF
RETURN lcOutput
ENDFUNC
FUNCTION HMMBT
LPARAMETERS tnNumber
#DEFINE HEZAR 'åÒÇÑ'
#DEFINE MILLION 'ãíáíæä '
#DEFINE MILLIARD 'ãíáíÇÑÏ'
#DEFINE BILLION 'Èíáíæä '
#DEFINE TRILLION 'ÊÑíáíæä '
DO CASE
CASE tnNumber = 1
RETURN ''
CASE tnNumber = 4
RETURN HEZAR
CASE tnNumber = 7
RETURN MILLION
CASE tnNumber = 10
RETURN MILLIARD
CASE tnNumber = 13
RETURN BILLION
CASE tnNumber = 16
RETURN TRILLION
ENDCASE
ENDFUNC
FUNCTION Num100
LPARAMETERS tcNumber
LOCAL lnSad,lnDah,lnYek,laYek,laDah,laDah2,laSad,lcOutpu t
tcNumber = PADL(tcNumber,3,'0')
lnSad = VAL(SUBSTR(tcNumber,1,1))
lnDah = VAL(SUBSTR(tcNumber,2,1))
lnYek = VAL(SUBSTR(tcNumber,3,1))
DIMENSION laYek(10),laDah(10),laDah2(10),laSad(10)
laYek(1) = ''
laYek(2) ='íß '
laYek(3) ='Ïæ '
laYek(4) ='Óå '
laYek(5) ='چåÇÑ'
laYek(6) ='پäÌ '
laYek(7) ='ÔÔ '
laYek(8) ='åÝÊ '
laYek(9) ='åÔÊ '
laYek(10) ='äå '
laDah(1) ='Ïå '
laDah(2) ='íÇÒÏå '
laDah(3) ='ÏæÇÒÏå '
laDah(4) ='ÓíÒÏå '
laDah(5) ='چåÇÑÏå '
laDah(6) ='پÇäÒÏå '
laDah(7) ='ÔÇäÒÏå '
laDah(8) ='åÝÏå '
laDah(9) ='åÌÏå '
laDah(10) ='äæÒÏå '
laDah2(2) ='ÈíÓÊ '
laDah2(3) ='Óí '
laDah2(4) ='چåá '
laDah2(5) ='پäÌÇå '
laDah2(6) ='ÔÕÊ'
laDah2(7) ='åÝÊÇÏ'
laDah2(8) ='åÔÊÇÏ'
laDah2(9) ='äæÏ'
laSad(1) = ''
laSad(2) ='íßÕÏ'
laSad(3) ='ÏæíÓÊ '
laSad(4) ='ÓíÕÏ'
laSad(5) ='چåÇÑÕÏ'
laSad(6) ='پÇäÕÏ'
laSad(7) ='ÔÔÕÏ'
laSad(8) ='åÝÊÕÏ'
laSad(9) ='åÔÊÕÏ'
laSad(10) ='äåÕÏ'
lcSad = laSad(lnSad+1)
lcDah =IIF(lnDah > 1 ,laDah2(lnDah)+IIF(lnYek#0,WA+laYek(lnYek+1),''),I IF( lnDah = 0 , IIF(lnYek#0,laYek(lnYek+1),''), laDah(lnYek+1)))
lcOutput = IIF(NOT EMPTY(lcSad) AND NOT EMPTY(lcDah),lcSad+WA+lcDah,lcSAD+lcDah)
RETURN lcOutPut
ENDFUNC
kia1349
یک شنبه 30 مهر 1385, 12:16 عصر
اینم برنامه اش
*********
*PROC NTOC
*********
PARAMETER Number
PRIVATE Number, Sgn, Len, Unit, LastUnit, String, Vav, Bignum1, ;
Bignum2, Bignum3, Strs, Loc, Digit, Sub
* SET STEP ON
M.Number = IIF(TYPE("M.Number") = "N", LTRIM(STR(M.Number, 15)), M.Number)
IF VAL(M.Number) > 999999999999999 OR VAL(M.Number) < -999999999999999
RETURN ("-1")
ENDIF
M.Sgn = IIF (VAL(M.Number) < 0 , "ãäÝí " , "")
IF VAL(M.Number) = 0
RETURN "ÕÝÑ"
ENDIF
M.Number = IIF(LEFT(M.Number,1) = "-", SUBSTR(M.Number,2), M.Number)
M.Len = LEN(M.Number)
STOR " " TO Unit,LastUnit
M.String = ""
M.Vav = "æ"
DIME Strs(3)
Strs(1) = "íß Ïæ Óå چåÇÑ پäÌ ÔÔ åÝÊ åÔÊ äå Ïå íÇÒÏå ÏæÇÒÏå ÓíÒÏå چåÇÑÏå پÇäÒÏå ÔÇäÒÏå åÝÏå åÌÏå äæÒÏå "
Strs(2) = "Ïå ÈíÓÊ Óí چåá پäÌÇå ÔÕÊ åÝÊÇÏ åÔÊÇÏ äæÏ "
Strs(3) = "íßÕÏ ÏæíÓÊ ÓíÕÏ چåÇÑÕÏ پÇäÕÏ ÔÔÕÏ åÝÊÕÏ åÔÊÕÏ äåÕÏ "
DO WHILE .T.
M.Digit = VAL(LEFT(M.Number,1))
M.Loc = MOD(M.Len,3)
IF M.Loc = 2 AND M.Digit = 1
M.Digit = VAL(LEFT(M.Number,2))
M.Loc = 1
ELSE
IF M.Loc = 0
M.Loc = 3
ENDIF
ENDIF
IF M.Digit # 0
DO CASE
CASE M.Len > 3 AND M.Len < 7
M.Unit = "åÒÇÑ"
CASE M.Len > 6 AND M.Len < 10
M.Unit = "ãíáíæä"
CASE M.Len > 9 AND M.Len < 13
M.Unit = "ãíáíÇÑÏ"
CASE M.Len > 12 AND M.Len < 16
M.Unit = "ÊÑíáíæä"
ENDCASE
ENDIF
M.Sub = IIF(M.Digit # 0, ALLTRIM(SUBSTR(Strs(M.Loc),(M.Digit-1)*7+1, 7)), "")
M.Len = M.Len - LEN(LTRIM(STR(M.Digit)))
M.Number = RIGHT(M.Number, M.Len)
IF M.Unit # M.LastUnit AND ((M.Loc = 1 OR (M.Loc = 3 .AND. VAL(M.Number) = 0)) ;
OR VAL(M.Number) = 0)
M.Sep = IIF(VAL(M.Number) > 0 , M.Vav , "")
M.String = IIF(LEN(M.Sub)=0, ALLTRIM(STRTRAN(M.String, M.Sep, "", OCCURS(M.Sep, M.String), 1)), ;
ALLTRIM(M.String)) + " " + M.Sub + " " + M.Unit + " " + M.Sep
M.LastUnit = M.Unit
ELSE
M.Sep = IIF(VAL(M.Number) > 0 AND LEN(M.Sub) # 0 AND M.Len > 0 AND M.Digit # 0, ;
M.Vav, "")
M.String = ALLTRIM(ALLTRIM(M.String) + " " + M.Sub + " " + M.Sep)
ENDIF
IF M.Len <= 0 OR VAL(M.Number) = 0
RETURN M.Sgn + ALLTRIM(M.String)
ENDIF
ENDDO
RETURN M.String
rezamim
دوشنبه 01 آبان 1385, 17:45 عصر
اینم کد من. یکم عجیبه نه؟
PROCEDURE NUMTOCHR
PARAMETER Num
PUBLIC ArrayDigit (36)
ArrayDigit (01) = " íß "
ArrayDigit (02) = " Ïæ "
ArrayDigit (03) = " Óå "
ArrayDigit (04) = " چåÇÑ "
ArrayDigit (05) = " پäÌ "
ArrayDigit (06) = " ÔÔ "
ArrayDigit (07) = " åÝÊ "
ArrayDigit (08) = " åÔÊ "
ArrayDigit (09) = " äå "
ArrayDigit (10) = " Ïå "
ArrayDigit (11) = " íÇÒÏå "
ArrayDigit (12) = " ÏæÇÒÏå "
ArrayDigit (13) = " ÓíÒÏå "
ArrayDigit (14) = " چåÇÑÏå "
ArrayDigit (15) = " پÇäÒÏå "
ArrayDigit (16) = " ÔÇäÒÏå "
ArrayDigit (17) = " åÝÏå "
ArrayDigit (18) = " åíÌÏå "
ArrayDigit (19) = " äæÒÏå "
ArrayDigit (20) = " ÈíÓÊ "
ArrayDigit (21) = " Óí "
ArrayDigit (22) = " چåá "
ArrayDigit (23) = " پäÌÇå "
ArrayDigit (24) = " ÔÕÊ "
ArrayDigit (25) = " åÝÊÇÏ "
ArrayDigit (26) = " åÔÊÇÏ "
ArrayDigit (27) = " äæÏ "
ArrayDigit (28) = " ÕÏ "
ArrayDigit (29) = " ÏæíÓÊ "
ArrayDigit (30) = " ÓíÕÏ "
ArrayDigit (31) = " چåÇÑÕÏ "
ArrayDigit (32) = " پÇäÕÏ "
ArrayDigit (33) = " ÔÔÕÏ "
ArrayDigit (34) = " åÝÊÕÏ "
ArrayDigit (35) = " åÔÊÕÏ "
ArrayDigit (36) = " äåÕÏ "
DO CASE
CASE Num >= 1000000000000000
RETURN NumToChr (Num / 1000000000000000) + "ÊÑíáíÇÑÏ " + IIF (Num % 1000000000000000 < 1, '', "æ") + NumToChr (Num % 1000000000000000)
CASE Num >= 1000000000000
RETURN NumToChr (Num / 1000000000000) + "ÊÑíáíæä " + IIF (Num % 1000000000000 < 1, '', "æ") + NumToChr (Num % 1000000000000)
CASE Num >= 1000000000
RETURN NumToChr (Num / 1000000000) + "ãíáíÇÑÏ " + IIF (Num % 1000000000 < 1, '', "æ") + NumToChr (Num % 1000000000)
CASE Num >= 1000000
RETURN NumToChr (Num / 1000000) + "ãíáíæä " + IIF (Num % 1000000 < 1, '', "æ") + NumToChr (Num % 1000000)
CASE Num >= 1000
RETURN NumToChr (Num / 1000) + "åÒÇÑ " + IIF (Num % 1000 < 1, '', "æ") + NumToChr (Num % 1000)
CASE Num >= 100
RETURN ArrayDigit (27 + Num / 100) + IIF(Num % 100 < 1, '', "æ") + NumToChr (Num % 100)
CASE Num >= 20
RETURN ArrayDigit (18 + Num / 10) + IIF (Num % 10 < 1, '', "æ") + NumToChr (Num % 10)
CASE Num >= 1
RETURN ArrayDigit (Num)
ENDCASE
RETURN ''
Web Matrix Pro
شنبه 20 آبان 1385, 14:06 عصر
بسیار عالی -ولی حروف فارسی در کد شما ناخواناسب
kia1349
یک شنبه 21 آبان 1385, 07:30 صبح
اینم برنامه
rezamim
دوشنبه 22 آبان 1385, 11:07 صبح
اینم برنامه ( تکه برنامه ) من !
تا تریلیارد جواب میده . یعنی 1000000000000000 ! شایدم بیشتر. خوشبختانه هنوز دارائیهام بزرگتر از این عدد نشده که ببینم جواب میده یا نه !!!!
javad_1349
پنج شنبه 30 آذر 1385, 10:02 صبح
سلام براساتید خودم واقعا عالی بود متشکرم
vBulletin® v4.2.5, Copyright ©2000-1404, Jelsoft Enterprises Ltd.