تبدیل مبلغ عددی به حروف

[shsoft]

با سلام
می خواستم بدونم شما اطلاعاتی در مورد تابع تبدیل مبلغ عددی به مبلغ حروفی دارید

به عنوان مثال اگر ورودی تابع مقدار 3.000.000 باشد
خروجی مقدار رشته ای سه میلیون ریال باشد

سه میلیون ریال=3.000.000

از راهنمایی شما متشکرم

[الهام تفریشی]

'توابع تبدیل عدد به معادل حروفی آن در زبان فارسی
'برنامه نویس : حمید آزادی اردکانی
'ویرایش اول : اردیبهشت 1380
' پست الکترونیک : azadi1355@yahoo.com
' آدرس وب : http://try.persianblog.com

Function Adad(ByVal Number As Double) As String
If Number = 0 Then
Adad = "صفر"
End If
Dim Flag As Boolean
Dim S As String
Dim I, L As Byte
Dim K(1 To 5) As Double

S = Trim(Str(Number))
L = Len(S)
If L > 15 Then
Adad = "بسیار بزرگ"
Exit Function
End If
For I = 1 To 15 - L
S = "0" & S
Next I
For I = 1 To Int((L / 3) + 0.99)
K(5 - I + 1) = Val(Mid(S, 3 * (5 - I) + 1, 3))
Next I
Flag = False
S = ""
For I = 1 To 5
If K(I) <> 0 Then
Select Case I
Case 1
S = S & Three(K(I)) & " تریلیون"
Flag = True
Case 2
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " میلیارد"
Flag = True
Case 3
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " میلیون"
Flag = True
Case 4
S = S & IIf(Flag = True, " و ", "") & Three(K(I)) & " هزار"
Flag = True
Case 5
S = S & IIf(Flag = True, " و ", "") & Three(K(I))
End Select
End If
Next I
Adad = S
End Function


Function Three(ByVal Number As Integer) As String
Dim S As String
Dim I, L As Long
Dim h(1 To 3) As Byte
Dim Flag As Boolean
L = Len(Trim(Str(Number)))
If Number = 0 Then
Three = ""
Exit Function
End If
If Number = 100 Then
Three = "یکصد"
Exit Function
End If

If L = 2 Then h(1) = 0
If L = 1 Then
h(1) = 0
h(2) = 0
End If

For I = 1 To L
h(3 - I + 1) = Mid(Trim(Str(Number)), L - I + 1, 1)
Next I

Select Case h(1)
Case 1
S = "یکصد"
Case 2
S = "دویست"
Case 3
S = "سیصد"
Case 4
S = "چهارصد"
Case 5
S = "پانصد"
Case 6
S = "ششصد"
Case 7
S = "هفتصد"
Case 8
S = "هشتصد"
Case 9
S = "نهصد"
End Select

Select Case h(2)
Case 1
Select Case h(3)
Case 0
S = S & " و " & "ده"
Case 1
S = S & " و " & "یازده"
Case 2
S = S & " و " & "دوازده"
Case 3
S = S & " و " & "سیزده"
Case 4
S = S & " و " & "چهارده"
Case 5
S = S & " و " & "پانزده"
Case 6
S = S & " و " & "شانزده"
Case 7
S = S & " و " & "هفده"
Case 8
S = S & " و " & "هجده"
Case 9
S = S & " و " & "نوزده"
End Select

Case 2
S = S & " و " & "بیست"
Case 3
S = S & " و " & "سی"
Case 4
S = S & " و " & "چهل"
Case 5
S = S & " و " & "پنجاه"
Case 6
S = S & " و " & "شصت"
Case 7
S = S & " و " & "هفتاد"
Case 8
S = S & " و " & "هشتاد"
Case 9
S = S & " و " & "نود"
End Select

If h(2) <> 1 Then
Select Case h(3)
Case 1
S = S & " و " & "یک"
Case 2
S = S & " و " & "دو"
Case 3
S = S & " و " & "سه"
Case 4
S = S & " و " & "چهار"
Case 5
S = S & " و " & "پنج"
Case 6
S = S & " و " & "شش"
Case 7
S = S & " و " & "هفت"
Case 8
S = S & " و " & "هشت"
Case 9
S = S & " و " & "نه"
End Select
End If
S = IIf(L < 3, Right(S, Len(S) - 3), S)
Three = S
End Function

' *********** End Of Module ***********

[saeid taheri]

خانم تفریش خیلی ممنون جالب بود :)

[shsoft]

از کمک شما متشکرم :)

[M-Gheibi]

این موضوع قبلا بحث شده :
http://www.barnamenevis.org/forum/viewtopic.php?t=6324
کدهای خوبی در این تاپیک پیدا میشه.

[linux]

:)
این کد به خاطر استفاده از دستور select case و iif به نظر میرسه که کند باشه

[vbstar]

سلام نور بالا عزیز
دلیل کند بودن را توضیح دهید ، چون برای کار من خیلی مهمه ؟

[linux]

select case از if کندتر هست و iif
300 بار if کند تر هست

[M-Gheibi]

آقای لینوکس من هم تا اونجایی که میدونم آرایه ها سریعتر از توابعی چون if و select case هستتد ولی میخواستم ببینم شما منبع معتبرتری در این مورد سراغ ندارید؟

[linux]

راستش یه چیزهایی تو msdn فکر کنم دیده بودم حالا اگر باز به چشمم خود مطلبشو میارم

[M-Gheibi]

ممنون :wink: