در به در بدنبال تابع تبدیل اعداد به حروف

[edisoon]

اگر کسی تابعی برای تبدیل اعداد به حروف داره اینجا بگذاره که خیلیها مثل من در به در دنبال این تابع هستند، البته من قبلا این تابع را داشتم ولی گمش کردم و حالا هم حوصله نوشتنش رو ندارم.
مثل : 1200000 یک میلیون و دویست هزار ریال

دمتون گرم

[mr_esmaily]

سلام
منم دنبال یه همچین چیزی میگیردم!
با تشکر قبلی :wink:

[JavanSoft]

با پاسکال دارم ... بدردتون می خوره؟

[مهدی کرامتی]

آقا سورسش رو بگذار اینجا من براشون تبدیل به Dll میکنم.

[namazi]

منم با paradax تحت داس این کا رو کردم که تا چار رقم رو تبدیل میکرد
ولی باید پیداش کنم

[giahchin]

من هم این تابع رو با FoxPro تحت داس نوشتم . خیلی هم خوب کار میکنه .
اگه به درد کسی میخوره میتونم بگذارمش اینجا ...

[M-Gheibi]

چقدر طالب داره این کد :shock:
این کد مورد نظر شما عزیزان هست. :wink:

Option Explicit
Private Const hezar = " هزار"
Private Const melun = " میلیون "
Private Const melyard = " میلیارد "
Private Const va = " و "

Public Function heji_adad(ByVal adad As Double) As String
Dim hooroof As String
Dim SS As Integer 'sadgan
Dim hh As Integer 'hezargan
Dim mm As Integer 'melungan
Dim yy As Integer 'melyardgan
Dim STRadad As String
Dim LENadad As Integer

STRadad = Str(Val(Str(adad)))
LENadad = Len(STRadad)

Select Case adad
Case Is = 0
hooroof = "صفر"
Case 1 To 999
hooroof = Adad_Heji(adad)

Case 1000 To 999999

If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar
If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000))

Case 1000000 To 999999999

SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Left$(STRadad, LENadad - 6))

If (SS = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(SS)
If (SS <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)

Case 1000000000 To 999999999999#

SS = Val(Right$(STRadad, 3))
hh = Val(Mid$(STRadad, LENadad - 5, 3))
mm = Val(Mid$(STRadad, LENadad - 8, 3))
yy = Val(Left$(STRadad, LENadad - 9))

If (SS = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard
If (SS = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun
If (SS = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar
If (SS <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS)

Case Is > 999999999999#
hooroof = "فکر کنم یادت رفت دستت را از روی صفحه کلید برداری "

End Select

heji_adad = hooroof
End Function

Private Function Adad_Heji(ByVal adad As Integer) As String
Dim yekan As Byte
Dim dahgan As Byte
Dim sadgan As Byte
Dim behooroof As String

Dim heji(19) As String
Dim heji_dahgan(9) As String
Dim heji_sadgan(9) As String
'-------------------------------
heji(1) = "یک": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج"
heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده"
heji(11) = "یازده": heji(12) = "دوازده": heji(13) = "سیزده": heji(14) = "چهارده": heji(15) = "پانزده"
heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هیجده": heji(19) = "نوزده"
'-------------------------------
heji_dahgan(1) = "ده"
heji_dahgan(2) = "بیست"
heji_dahgan(3) = "سی": heji_dahgan(4) = "چهل": heji_dahgan(5) = "پنجاه"
heji_dahgan(6) = "شصت": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد"
heji_dahgan(9) = "نود"
'------------------------
heji_sadgan(1) = "یکصد": heji_sadgan(2) = "دویست": heji_sadgan(3) = "سیصد"
heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد"
heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد"
'------------------------------------------------------------------------------------------------------------
yekan = adad Mod 10
dahgan = adad Mod 100
sadgan = Int(adad / 100)
'------------------------------------------------------------------------------------------------------------
If dahgan < 20 Then

If (sadgan = 0) Then behooroof = heji(dahgan)
If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan)
If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan)

Else
dahgan = (adad Mod 100) - yekan

If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10)
If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan)
If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10)
If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan)

End If

Adad_Heji = behooroof
End Function

نویسنده : بابک بخشایش
نحوه استفاده :

heji_adad(عدد مورد نظر)
نکته :
ماکزیمم عدد قابل استفاده : 999.999.999.999

چیز دیگه ای خواستید در خدمتم. :wink:

[کم حوصله]

بابا یکم حوصله به خرج بدید چقدر شما ها کم حوصله اید :P :P



Public Function change_mony(ByVal Pol As Variant) As String
Dim P As String, p1 As String
Dim P2 As String, P3 As String
Dim P4 As String, Sk As String
Dim L As Byte
If Pol > 0 Then
P = Str(Pol)
Sk = Right(Trim(P), 3)
p1 = harf(Val(Trim(Sk)))
p1 = Trim(p1) & " ریال"
If Len(Trim(P)) > 3 Then
Sk = Right(Trim(P), 6)
L = Len(Trim(Sk))
Sk = Left(Trim(Sk), (L - 3))
P2 = harf(Val(Trim(Sk)))
P2 = Trim(P2) & " هزار و"
End If
If Len(Trim(P)) > 6 Then
Sk = Right(Trim(P), 9)
L = Len(Trim(Sk))
Sk = Left(Trim(Sk), (L - 6))
P3 = harf(Val(Trim(Sk)))
P3 = Trim(P3) & " میلیون و"
End If
If Len(Trim(P)) = 10 Then
Sk = Left(Trim(P), 1)
P4 = harf(Val(Trim(Sk)))
P4 = Trim(P4) & " میلیارد و"
End If
change_mony = Trim(P4) & Trim(P3) & Trim(P2) & Trim(p1)
End If
End Function

Private Function harf(mony2 As Long) As String
Dim S As String, s1 As String
Dim s2 As String, s3 As String
S = Trim(Str(mony2))
If Len(Trim(Str(mony2))) = 1 Then S = "00" & Trim(Str(mony2))
If Len(Trim(Str(mony2))) = 2 Then S = "0" & Trim(Str(mony2))
Select Case Left(Trim(S), 1)
Case 0
s1 = ""
Case 1
s1 = "یکصد"
Case 2
s1 = "دویست"
Case 3
s1 = "سیصد"
Case 4
s1 = "چهارصد"
Case 5
s1 = "پانصد"
Case 6
s1 = "ششصد"
Case 7
s1 = "هفتصد"
Case 8
s1 = "هشتصد"
Case 9
s1 = "نهصد"
End Select
Select Case Mid(Trim(S), 2, 1)
Case 0
s2 = ""
Case 1
Select Case Right(Trim(S), 1)
Case 0
s2 = "ده"
Case 1
s2 = "یازده"
Case 2
s2 = "دوازده"
Case 3
s2 = "سیزده"
Case 4
s2 = "چهارده"
Case 5
s2 = "پانزده"
Case 6
s2 = "شانزده"
Case 7
s1 = "هفده"
Case 8
s1 = "هجده"
Case 9
s1 = "نوزده"
End Select
Case 2
s2 = "بیست"
Case 3
s2 = "سی"
Case 4
s2 = "چهل"
Case 5
s2 = "پنجاه"
Case 6
s2 = "شصت"
Case 7
s2 = "هفتاد"
Case 8
s2 = "هشتاد"
Case 9
s2 = "نود"
End Select
If Mid(Trim(S), 2, 1) <> 1 Then
Select Case Right(Trim(S), 1)
Case 0
s3 = ""
Case 1
s3 = "یک"
Case 2
s3 = "دو"
Case 3
s3 = "سه"
Case 4
s3 = "چهار"
Case 5
s3 = "پنج"
Case 6
s3 = "شش"
Case 7
s3 = "هفت"
Case 8
s3 = "هشت"
Case 9
s3 = "نه"
End Select
End If
If Trim(s1) <> "" Then s1 = s1 & " و"
If Trim(s2) <> "" Then s2 = s2 & " و"
If Trim(s3) <> "" Then s3 = s3 & " و"
S = s1 & s2 & s3
If Trim(S) <> "" Then harf = Left(Trim(S), (Len(Trim(S)) - 1)) Else harf = ""
End Function

[کم حوصله]

این کد را می توانید تا هر مقدار که دوست دارید افزایش دهید کافیست یکم" کم حوصله " نباشید :mrgreen: :mrgreen:
راستی فانکشن اصلیه Change_mony() می باشد

به قول گلاد جونم برید حالشو ببرید :wink:

[linux]

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


Dim pt As New PersianTools
MsgBox (pt.DigitToPersianString(12544))
MsgBox (pt.DateToPersian(Now).LongDate)

[vbstar]

آقای نوربالا ، اگر لطف کنی و سورس این برنامه Dll رو نیز برای استفاده ما روی این سایت بگذارید ، عالیه.

یکبار یه سورس خیلی خوب از تبدیل تاریخ گذاشتی که خیلی به من کمک کرد.

[vbstar]

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


Function ConvertCurrencyToEnglish(ByVal MyNumber)

'Syntax :
'=ConvertCurrencyToEnglish([نام فیلدی که باید مبلغ عددی آن بحروف تبدیل شود])
'=ConvertCurrencyToEnglish([Total])
Dim Temp
Dim Dollars, Cents
Dim DecimalPlace, Count

ReDim Place(9) As String
Place(2) = " هزار و "
Place(3) = " میلیون و "
Place(4) = " میلیارد و "
Place(5) = " تریلون و "

' Convert MyNumber to a string, trimming extra spaces.
MyNumber = Trim(str(MyNumber))

' Find decimal place.
DecimalPlace = InStr(MyNumber, ".")

' If we find decimal place...
If DecimalPlace > 0 Then
' Convert cents
Temp = Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2)
Cents = ConvertTens(Temp)

' Strip off cents from remainder to convert.
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If

Count = 1
Do While MyNumber <> ""
' Convert last 3 digits of MyNumber to English dollars.
Temp = ConvertHundreds(Right(MyNumber, 3))
If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
If Len(MyNumber) > 3 Then
' Remove last 3 converted digits from MyNumber.
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop

' Clean up dollars.
Select Case Dollars
Case ""
Dollars = "" '"No Dollars"
Case "One"
Dollars = "یک تومان" '"One Dollar"
Case Else
Dollars = Dollars & " ریال" 'تومان
End Select

' Clean up cents.
Select Case Cents
Case ""
Cents = "" '" And No Cents"
Case "One"
Cents = "یک ریال" '" And One Cent"
Case Else
Cents = " و " & Cents & " ریال"
End Select

ConvertCurrencyToEnglish = Dollars & Cents
End Function

'تبدیل رقم یکان به معادل حروفی
Private Function ConvertDigit(ByVal MyDigit)
Select Case Val(MyDigit)
Case 1: ConvertDigit = "یک"
Case 2: ConvertDigit = "دو"
Case 3: ConvertDigit = "سه"
Case 4: ConvertDigit = "چهار"
Case 5: ConvertDigit = "پنج"
Case 6: ConvertDigit = "شش"
Case 7: ConvertDigit = "هفت"
Case 8: ConvertDigit = "هشت"
Case 9: ConvertDigit = "نه"
Case Else: ConvertDigit = ""
End Select

End Function

Private Function ConvertHundreds(ByVal MyNumber)
Dim Result As String

' Exit if there is nothing to convert.
If Val(MyNumber) = 0 Then Exit Function

' Append leading zeros to number.
MyNumber = Right("000" & MyNumber, 3)

' Do we have a hundreds place digit to convert?
If Left(MyNumber, 1) <> "0" Then
' Result = ConvertDigit(left(MyNumber, 1)) & " صـد "
Result = Convert100(Left(MyNumber, 1)) & " "
End If

' Do we have a tens place digit to convert?
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & ConvertTens(Mid(MyNumber, 2))
Else
' If not, then convert the ones place digit.
Result = Result & ConvertDigit(Mid(MyNumber, 3))
End If

ConvertHundreds = Trim(Result)
End Function

Private Function ConvertTens(ByVal MyTens)
Dim Result As String
' Is value between 10 and 19?
If Val(Left(MyTens, 1)) = 1 Then
Select Case Val(MyTens)
Case 10: Result = "ده"
Case 11: Result = "یازده"
Case 12: Result = "دوازده"
Case 13: Result = "سیزده"
Case 14: Result = "چهارده"
Case 15: Result = "پانزده"
Case 16: Result = "شانزده"
Case 17: Result = "هفده"
Case 18: Result = "هیجده"
Case 19: Result = "نوزده"
Case Else
End Select
Else
' .. otherwise it's between 20 and 99.
Select Case Val(Left(MyTens, 1))
Case 2: Result = "بیست "
Case 3: Result = "سی "
Case 4: Result = "چهل "
Case 5: Result = "پنجاه "
Case 6: Result = "شصت "
Case 7: Result = "هفتاد "
Case 8: Result = "هشتاد "
Case 9: Result = "نود "
Case Else
End Select
' Convert ones place digit.
Result = Result & ConvertDigit(Right(MyTens, 1))
End If
ConvertTens = Result
End Function

'تبدیل رقم صدگان به معادل حروفی
' 100 between 900?
Public Function Convert100(ByVal MyDigit1)
Select Case Val(MyDigit1)
Case 1: Convert100 = "یکصد"
Case 2: Convert100 = "دویست"
Case 3: Convert100 = "سیصد"
Case 4: Convert100 = "چهارصد"
Case 5: Convert100 = "پانصد"
Case 6: Convert100 = "ششصد"
Case 7: Convert100 = "هفتصد"
Case 8: Convert100 = "هشتصد"
Case 9: Convert100 = "نهصد"
Case Else: Convert100 = ""
End Select
End Function

شما می توانید این برنامه را در یک ماژول ذخیره کنید و هرکجا خواستید اسم ماژول را فراخوانی کنید.

VBstar

[linux]

سلام!
توی اینجور جایگذاری ها از select case استفاده نکنید کند میشه! از آریه ها استفاده کنید

[کم حوصله]

علت کندی چیه و مزیت آرایه در چی هست ؟؟؟ :)

[(سیدشریفی)]

آقای مسعود غیبی خیلی خوب بود دستت درد نکنه
از دیگر عزیزان نیز کمال تشکر را دارم
:lol: :lol: :lol:

[علیرضا مداح]

آقای غیبی دست مریزاد !
منم به این کد خیلی احتیاج داشتم . :wink:

[SH_Zahra]

ببخشید این کدها را کجا بنویسیم ؟ :mrgreen: :mrgreen: :mrgreen:

روی فرممون چی طراجی کنیم :cry:

[vbadvanced]

اینو قبلا هم گداشته بودم اما یه بار دیگه عیبی نداره.


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