تابعی برای گرفتن یک عدد و تبدیل آم به معادل حرفی. مثلا عدد 1234567 را می گیرد و عبارت "یک میلیون و دویست و سی و چهار هزار و پانصد و شصت و هفت" را بر می گرداند
این تابع که بصورت عمده در سیستم های مالی و حسابداری مورد نیاز است، معادل حروفی اعداد را بر می گرداند. مثلا برای چاپ یک چک روی خود برگه چک ، علاوه بر نیاز به چاپ مبلغ عددی چک لازمست تا مبلغ حروفی چک هم روی برگه چاپ شود. نحوه استفاده از تابع : تابع Adad که در زیر ارایه شده است یک عدد را بعنوان ورودی گرفته و معادل حروفی آن عدد در زبان فارسی را بعنوان خروجی تولید می کند. مثلا (Adad(1373 مقدار"یکهزار و سیصد و هفتاد و سه" را بعنوان خروجی تولید می کند.برای استفاده از این توابع باید از چند خط پایین تر (Start of Module) تا انتهای این یادداشت را در حافظه کپی (Copy) کرده و در یک ماجول جدید در اکسس یا VB ، Paste کنید . ( توجه داشته باشید که نمایش کدهای نوشته شده در اینجا راست به چپ است که پس از کپی کردن آن در ماجول اکسس بشکل صحیح نمایش داده خواهد شد) ' *********** Start of Module *********** 'توابع تبدیل عدد به معادل حروفی آن در زبان فارسی 'برنامه نویس : حمید آزادی اردکانی 'ویرایش اول : اردیبهشت 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 *********** |
