تابع تبديل عدد به حروف
مقدمه :
در اين يادداشت تابع مربوط به تبديل عدد به معادل حروفي آن ارائه مي كنم . عمدتا در سيستم هاي مالي و حسابداري نياز است معادل حروفي اعداد هم نمايش داده شده يا چاپ شوند كه توابع زير اين نياز را پاسخ مي دهد. مثلا براي چاپ يك چك روي خود برگه چك ، علاوه بر نياز به چاپ مبلغ عددي چك لازمست تا مبلغ حروفي چك هم روي برگه چاپ شود.

نحوه استفاده از تابع :
تابع Adad كه در زير ارائه شده است يك عدد را بعنوان ورودي گرفته و معادل حروفي آن عدد در زبان فارسي را بعنوان خروجي توليد مي كند. مثلا (Adad(1373 مقدار"يكهزار و سيصد و هفتاد و سه" را بعنوان خروجي توليد مي كند.براي استفاده از اين توابع بايد از چند خط پايين تر (Start of Module) تا انتهاي اين يادداشت را در حافظه كپي (Copy) كرده و در يك ماجول جديد در اكسس يا VB ، Paste كنيد . ( توجه داشته باشيد كه نمايش كدهاي نوشته شده در اينجا راست به چپ است كه پس از كپي كردن آن در ماجول اكسس بشكل صحيح نمايش داده خواهد شد)




' *********** Start of Module ***********

'توابع تبديل عدد به معادل حروفي آن در زبان فارسي
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