تبدیل عدد به حروف فارسی و انگلیسی در Microsoft Access به فایل اکسس قابل دانلود

گاهی اوقات لازم است که در برنامه اکسس اعداد را به حروف تبدیل کنید. به عنوان مثال ممکن است نیاز داشته باشید عدد 4251 به صورت چهار هزار و دویست و پنجاه و یک تبدیل کرده و نمایش دهید. برای این منظور میتوانید از دو فانکشن زیر برای تبدیل عدد به حروف استفاده کنید. یک از مجموع توابع برای تبدیل عدد به حروف فارسی و یکی دیگر از مجموع توابع برای تبدیل عدد به حروف انگلیسی می باشد.

متد تبدیل اعداد به حروف و رشته فارسی در برنامه Microsoft Access:

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

متد تبدیل اعداد به حروف انگلیسی در برنامه Microdoft Access

Public Function wsiSpellNumber(ByVal MyNumber)

    Dim Dollars, Cents, Temp

    Dim DecimalPlace, Count

    ReDim Place(9) As String

    Place(2) = " Thousand "

    Place(3) = " Million "

    Place(4) = " Billion "

    Place(5) = " Trillion "

    ' String representation of amount.

    MyNumber = Trim(Str(MyNumber))

    ' Position of decimal place 0 if none.

    DecimalPlace = InStr(MyNumber, ".")

    ' Convert cents and set MyNumber to dollar amount.

    If DecimalPlace > 0 Then

        Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _

                  "00", 2))

        MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))

    End If

    Count = 1

    Do While MyNumber <> ""

        Temp = GetHundreds(Right(MyNumber, 3))

        If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars

        If Len(MyNumber) > 3 Then

            MyNumber = Left(MyNumber, Len(MyNumber) - 3)

        Else

            MyNumber = ""

        End If

        Count = Count + 1

    Loop

    Select Case Dollars

        Case ""

            Dollars = "No Dollars"

        Case "One"

            Dollars = "One Dollar"

         Case Else

            Dollars = Dollars & " Dollars"

    End Select

    Select Case Cents

        Case ""

            Cents = " and No Cents"

        Case "One"

            Cents = " and One Cent"

              Case Else

            Cents = " and " & Cents & " Cents"

    End Select

    wsiSpellNumber = Dollars & Cents

End Function

' Converts a number from 100-999 into text

Function GetHundreds(ByVal MyNumber)

    Dim result As String

    If Val(MyNumber) = 0 Then Exit Function

    MyNumber = Right("000" & MyNumber, 3)

    ' Convert the hundreds place.

    If Mid(MyNumber, 1, 1) <> "0" Then

        result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "

    End If

    ' Convert the tens and ones place.

    If Mid(MyNumber, 2, 1) <> "0" Then

        result = result & GetTens(Mid(MyNumber, 2))

    Else

        result = result & GetDigit(Mid(MyNumber, 3))

    End If

    GetHundreds = result

End Function

' Converts a number from 10 to 99 into text.

Function GetTens(TensText)

    Dim result As String

    result = ""           ' Null out the temporary function value.

    If Val(Left(TensText, 1)) = 1 Then   ' If value between 10-19...

        Select Case Val(TensText)

            Case 10: result = "Ten"

            Case 11: result = "Eleven"

            Case 12: result = "Twelve"

            Case 13: result = "Thirteen"

            Case 14: result = "Fourteen"

            Case 15: result = "Fifteen"

            Case 16: result = "Sixteen"

            Case 17: result = "Seventeen"

            Case 18: result = "Eighteen"

            Case 19: result = "Nineteen"

            Case Else

        End Select

    Else                                 ' If value between 20-99...

        Select Case Val(Left(TensText, 1))

            Case 2: result = "Twenty "

            Case 3: result = "Thirty "

            Case 4: result = "Forty "

            Case 5: result = "Fifty "

            Case 6: result = "Sixty "

            Case 7: result = "Seventy "

            Case 8: result = "Eighty "

            Case 9: result = "Ninety "

            Case Else

        End Select

        result = result & GetDigit _

            (Right(TensText, 1))  ' Retrieve ones place.

    End If

    GetTens = result

End Function

' Converts a number from 1 to 9 into text.

Function GetDigit(Digit)

    Select Case Val(Digit)

        Case 1: GetDigit = "One"

        Case 2: GetDigit = "Two"

        Case 3: GetDigit = "Three"

        Case 4: GetDigit = "Four"

        Case 5: GetDigit = "Five"

        Case 6: GetDigit = "Six"

        Case 7: GetDigit = "Seven"

        Case 8: GetDigit = "Eight"

        Case 9: GetDigit = "Nine"

        Case Else: GetDigit = ""

    End Select

End Function

مثال اجرا شده در اکسس (شکل زیر)

لینک دانلود پروژه (Download Link)

نکته: اگر در هنگام اجرای پروژه با پیغام  Security Warning مواجه شدین بر روی Enable Contetnt کلیک کنین. در غیر اینصورت ممکنه در پروژه دانلود شده متدها عملکرد خودشون رو به درستی انجام ندهند. (شکل زیر)