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

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

توسط admin | گروه برنامه نویسی | 1396/04/18

نظرات 3

تبدیل عدد به حروف فارسی و انگلیسی در 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 کلیک کنین. در غیر اینصورت ممکنه در پروژه دانلود شده متدها عملکرد خودشون رو به درستی انجام ندهند. (شکل زیر)

Enabled Content

 

 

 

3 نظر

ارسال شده توسط مدیر کل
1399/07/25

سلام و عرض ادب و احترام. لینک فایل دانلودی سمپل اکسس در انتهای مقاله برای دانلود موجود می باشد. می‌توانید از همان فایل پروژه اکسس استفاده فرمایید که قبلا تست شده. با تشکر.

ارسال شده توسط شاهرخ
1399/05/20

درود بر شما من این پروژه رو نصب کردم ولی متاسفانه اجرا نمیشه. راهنامیی بفرمایید لطفا سپاس جمشیدی

ارسال شده توسط محمود حسینی
1398/01/28

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

نظر محترم شما در مورد مقاله های وب سایت برنامه نویسی و پایگاه داده

نظرات محترم شما در خدمات رسانی بهتر ما را یاری می نمایند. لطفا اگر مایل بودید یک نظر ما را مهمان فرمائید. آدرس ایمیل و وب سایت شما نمایش داده نخواهد شد.

حرف 500 حداکثر

اطلاعات تماس

  • آدرس:اصفهان-خیابان ام کلثوم غربی - بعد خیابان تخم چی - بیست متر بعد از پیتزا ننه شب - کوچه تعمیر گاه سمار زغالی - پلاک 354 - درب مشکی - طبقه هفتم
  • آدرس ایمیل:najafzade@gmail.com
  • وب سایت:http://www.a00b.com/
  • تلفن ثابت:(+98)9131253620
  • تلفن همراه:09131253620