اذهب الي المحتوي
aziz77

كود تحويل الأرقام إلى حروف في الأكسس

المشاركات الموصى بها

هل يمكن باكسس تحويل الأرقام الي ارقام حروف مثل رقم ( 125 ريال) هل يمكن تحويلة الي (مائة و خمسة و عشرون ريال) قمت بعمل نموذج للقيود اليومية و اريد اضع خاصية كتابة الأرقام أليا فكيف يمكن ذلك في اكسس ممكن بالتفصيل لو سمحتم انا مببتدئ في اكسس و اتمنا لكم التوفيق

شارك هذه المشاركه


رابط المشاركه
شارك

أخي الكريم

هذا الكود يحول من الأرقام إلى الحروف و لكن باللغة الأنجليزية و هو بالطبع بلغة الفيجوال بيسك للتطبيقات المرفقة مع قواعد بيانات أكسس و يمكنك وضع الكود في MODULE و تسميه NumberToWrod و تقوم بعمل اللازم بعد ذلك

و الكود هو

[B][SIZE=6][B][SIZE=3]Function ConvertCurrencyToEnglish(ByVal mynumber)

         Dim Temp
         Dim Dollars, Cents
         Dim DecimalPlace, Count

         ReDim Place(9) As String
         Place(2) = " Thousand "
         Place(3) = " Million "
         Place(4) = " Billion "
         Place(5) = " Trillion "

         ' Convert MyNumber to a string, trimming extra spaces.
         If Not mynumber = Null Then
         
         mynumber = Trim(Str(mynumber))
         
         
         End If
         

         ' Find decimal place.
         DecimalPlace = InStr(mynumber, ".")

         ' If we find decimal place...
         If DecimalPlace > 0 Then
            ' Convert cents
            Temp = Left(Mid(mynumber, DecimalPlace + 1) & "00", 2)
            Cents = ConvertTens(Temp)

            ' Strip off cents from remainder to convert.
            mynumber = Trim(Left(mynumber, DecimalPlace - 1))
         End If

         Count = 1
         Do While mynumber <> ""
            ' Convert last 3 digits of MyNumber to English dollars.
            Temp = ConvertHundreds(Right(mynumber, 3))
            If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
            If Len(mynumber) > 3 Then
               ' Remove last 3 converted digits from MyNumber.
               mynumber = Left(mynumber, Len(mynumber) - 3)
            Else
               mynumber = ""
            End If
            Count = Count + 1
         Loop

         ' Clean up dollars.
         Select Case Dollars
            Case ""
               Dollars = "Zero Dirham"
            Case "One"
               Dollars = "One Dirham"
            Case Else
               Dollars = Dollars & " Dirhams"
         End Select

         ' Clean up cents.
         Select Case Cents
            Case ""
               Cents = " And Zero Fils Only."
            Case "One"
               Cents = " And One Fils Only."
            Case Else
               Cents = " And " & Cents & " Fils Only."
         End Select

         ConvertCurrencyToEnglish = Dollars & Cents
      End Function

      Private Function ConvertHundreds(ByVal mynumber)
         Dim Result As String

         ' Exit if there is nothing to convert.
         If Val(mynumber) = 0 Then Exit Function

         ' Append leading zeros to number.
         mynumber = Right("000" & mynumber, 3)

         ' Do we have a hundreds place digit to convert?
         If Left(mynumber, 1) <> "0" Then
            Result = ConvertDigit(Left(mynumber, 1)) & " Hundred "
         End If

         ' Do we have a tens place digit to convert?
         If Mid(mynumber, 2, 1) <> "0" Then
            Result = Result & ConvertTens(Mid(mynumber, 2))
         Else
            ' If not, then convert the ones place digit.
            Result = Result & ConvertDigit(Mid(mynumber, 3))
         End If

         ConvertHundreds = Trim(Result)
      End Function

      Private Function ConvertTens(ByVal MyTens)
         Dim Result As String

         ' Is value between 10 and 19?
         If Val(Left(MyTens, 1)) = 1 Then
            Select Case Val(MyTens)
               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
            ' .. otherwise it's between 20 and 99.
            Select Case Val(Left(MyTens, 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

            ' Convert ones place digit.
            Result = Result & ConvertDigit(Right(MyTens, 1))
         End If

         ConvertTens = Result
      End Function

      Private Function ConvertDigit(ByVal MyDigit)
         Select Case Val(MyDigit)
            Case 1: ConvertDigit = "One"
            Case 2: ConvertDigit = "Two"
            Case 3: ConvertDigit = "Three"
            Case 4: ConvertDigit = "Four"
            Case 5: ConvertDigit = "Five"
            Case 6: ConvertDigit = "Six"
            Case 7: ConvertDigit = "Seven"
            Case 8: ConvertDigit = "Eight"
            Case 9: ConvertDigit = "Nine"
            Case Else: ConvertDigit = ""
         End Select[/SIZE]
      [SIZE=3]End Function[/SIZE][/B][/SIZE][/B]
تم تعديل بواسطه admin

" قُلِ اللَّهُمَّ مَالِكَ الْمُلْكِ تُؤْتِي الْمُلْكَ مَنْ تَشَاءُ وَتَنْزِعُ الْمُلْكَ مِمَّنْ تَشَاءُ وَتُعِزُّ مَنْ تَشَاءُ وَتُذِلُّ مَنْ تَشَاءُ بِيَدِكَ الْخَيْرُ إِنَّكَ عَلَى كُلِّ شَيْءٍ قَدِيرٌ"

مدير الموقع

شارك هذه المشاركه


رابط المشاركه
شارك

[align=left:b5d967e570]

Function NoToTxt2(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim Myno As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim I As Integer
Dim ReMark As String


If TheNo > 999999999999.999 Then Exit Function

If TheNo < 0 Then
TheNo = TheNo * -1
ReMark = "لم يتبقي "
Else
ReMark = "فقط "
End If

If TheNo = 0 Then
NoToTxt2 = "صفر"
Exit Function
End If

MyAnd = " و"
MyArry1(0) = ""
MyArry1(1) = "مائة"
MyArry1(2) = "مائتان"
MyArry1(3) = "ثلاثمائة"
MyArry1(4) = "اربعمائة"
MyArry1(5) = "خمسمائة"
MyArry1(6) = "ستمائة"
MyArry1(7) = "سبعمائة"
MyArry1(8) = "ثمانمائة"
MyArry1(9) = "تسعمائة"

MyArry2(0) = ""
MyArry2(1) = " عشر"
MyArry2(2) = "عشرون"
MyArry2(3) = "ثلاثون"
MyArry2(4) = "اربعون"
MyArry2(5) = "خمسون"
MyArry2(6) = "ستون"
MyArry2(7) = "سبعون"
MyArry2(8) = "ثمانون"
MyArry2(9) = "تسعون"

MyArry3(0) = ""
MyArry3(1) = "احدي"
MyArry3(2) = "اثنان"
MyArry3(3) = "ثلاثة"
MyArry3(4) = "اربعة"
MyArry3(5) = "خمسة"
MyArry3(6) = "ستة"
MyArry3(7) = "سبعة"
MyArry3(8) = "ثمانية"
MyArry3(9) = "تسعة"
'======================
GetNo = Round(TheNo, 3)
GetNo = Format(TheNo, "000000000000.000")

I = 0
'===============
Do While I < 16

If I < 12 Then
Myno = Mid$(GetNo, I + 1, 3)
Else
Myno = Mid$(GetNo, I + 2, 3) + "0" ' "0" + Mid$(GetNo, I + 2, 2)
End If

If (Mid$(Myno, 1, 3)) > 0 Then

RdNo = Mid$(Myno, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(Myno, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(Myno, 2, 1)
My10 = MyArry2(RdNo)

If Mid$(Myno, 2, 2) = 11 Then My11 = "احدي عشر"
If Mid$(Myno, 2, 2) = 12 Then My12 = "اثني عشر"
If Mid$(Myno, 2, 2) = 10 Then My10 = "عشرة"

If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd

GetTxt = My100 + My1 + My10

If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11
End If

If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12
End If

If (I = 0) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
Mybillion = GetTxt + " مليار"
Else
Mybillion = GetTxt + " مليارات"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " مليار"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ملياران"
End If
End If

If (I = 3) And (GetTxt <> "") Then

If ((Mid$(Myno, 1, 3)) > 10) Then
MyMillion = GetTxt + " مليون"
Else
MyMillion = GetTxt + " ملايين"
If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " مليون"
If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " مليونان"
End If
End If

If (I = 6) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
MyThou = GetTxt + " الف"
Else
MyThou = GetTxt + " الاف"
If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " الف"
If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " الفان"
End If
End If

If (I = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (I = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If

I = I + 3
Loop
'============================
If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If

If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If

If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If

If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt2 = ReMark + MyFraction + " " + MySubCur
End If
Else
NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If

End Function
[/align:b5d967e570]

شارك هذه المشاركه


رابط المشاركه
شارك

السلام عليكم ورحمة الله وبركاته

بصراحة الموضوع جميل جدا ويستحق الاهتمام،، أنا الآن عملت برنامج عن طريق الاكسس يخص المحاسبة لكن أرغب في أن يكون التفقيط بالاحرف عن طريق البرنامج مثل طلب الاخ عزيز وأيضاً أنا مبتديء وأريد الشرح بالتفصيل ،، فضلاً لا أمرا طبعا

وتحياتي للجميع

شارك هذه المشاركه


رابط المشاركه
شارك
On 8/4/2006 at 8:51 PM, ATEF SOLIMAN said:

[align=left:b5d967e570]


Function NoToTxt2(TheNo As Double, MyCur As String, MySubCur As String) As String
Dim MyArry2(0 To 9) As String
Dim MyArry3(0 To 9) As String
Dim Myno As String
Dim GetNo As String
Dim RdNo As String
Dim My100 As String
Dim My10 As String
Dim My1 As String
Dim My11 As String
Dim My12 As String
Dim GetTxt As String
Dim Mybillion As String
Dim MyMillion As String
Dim MyThou As String
Dim MyHun As String
Dim MyFraction As String
Dim MyAnd As String
Dim I As Integer
Dim ReMark As String


If TheNo > 999999999999.999 Then Exit Function

If TheNo < 0 Then
TheNo = TheNo * -1
ReMark = "لم يتبقي "
Else
ReMark = "فقط "
End If

If TheNo = 0 Then
NoToTxt2 = "صفر"
Exit Function
End If

MyAnd = " و"
MyArry1(0) = ""
MyArry1(1) = "مائة"
MyArry1(2) = "مائتان"
MyArry1(3) = "ثلاثمائة"
MyArry1(4) = "اربعمائة"
MyArry1(5) = "خمسمائة"
MyArry1(6) = "ستمائة"
MyArry1(7) = "سبعمائة"
MyArry1(8) = "ثمانمائة"
MyArry1(9) = "تسعمائة"

MyArry2(0) = ""
MyArry2(1) = " عشر"
MyArry2(2) = "عشرون"
MyArry2(3) = "ثلاثون"
MyArry2(4) = "اربعون"
MyArry2(5) = "خمسون"
MyArry2(6) = "ستون"
MyArry2(7) = "سبعون"
MyArry2(8) = "ثمانون"
MyArry2(9) = "تسعون"

MyArry3(0) = ""
MyArry3(1) = "احدي"
MyArry3(2) = "اثنان"
MyArry3(3) = "ثلاثة"
MyArry3(4) = "اربعة"
MyArry3(5) = "خمسة"
MyArry3(6) = "ستة"
MyArry3(7) = "سبعة"
MyArry3(8) = "ثمانية"
MyArry3(9) = "تسعة"
'======================
GetNo = Round(TheNo, 3)
GetNo = Format(TheNo, "000000000000.000")

I = 0
'===============
Do While I < 16

If I < 12 Then
Myno = Mid$(GetNo, I + 1, 3)
Else
Myno = Mid$(GetNo, I + 2, 3) + "0" ' "0" + Mid$(GetNo, I + 2, 2)
End If

If (Mid$(Myno, 1, 3)) > 0 Then

RdNo = Mid$(Myno, 1, 1)
My100 = MyArry1(RdNo)
RdNo = Mid$(Myno, 3, 1)
My1 = MyArry3(RdNo)
RdNo = Mid$(Myno, 2, 1)
My10 = MyArry2(RdNo)

If Mid$(Myno, 2, 2) = 11 Then My11 = "احدي عشر"
If Mid$(Myno, 2, 2) = 12 Then My12 = "اثني عشر"
If Mid$(Myno, 2, 2) = 10 Then My10 = "عشرة"

If ((Mid$(Myno, 1, 1)) > 0) And ((Mid$(Myno, 2, 2)) > 0) Then My100 = My100 + MyAnd
If ((Mid$(Myno, 3, 1)) > 0) And ((Mid$(Myno, 2, 1)) > 1) Then My1 = My1 + MyAnd

GetTxt = My100 + My1 + My10

If ((Mid$(Myno, 3, 1)) = 1) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My11
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My11
End If

If ((Mid$(Myno, 3, 1)) = 2) And ((Mid$(Myno, 2, 1)) = 1) Then
GetTxt = My100 + My12
If ((Mid$(Myno, 1, 1)) = 0) Then GetTxt = My12
End If

If (I = 0) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
Mybillion = GetTxt + " مليار"
Else
Mybillion = GetTxt + " مليارات"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " مليار"
If ((Mid$(Myno, 1, 3)) = 2) Then Mybillion = " ملياران"
End If
End If

If (I = 3) And (GetTxt <> "") Then

If ((Mid$(Myno, 1, 3)) > 10) Then
MyMillion = GetTxt + " مليون"
Else
MyMillion = GetTxt + " ملايين"
If ((Mid$(Myno, 1, 3)) = 1) Then MyMillion = " مليون"
If ((Mid$(Myno, 1, 3)) = 2) Then MyMillion = " مليونان"
End If
End If

If (I = 6) And (GetTxt <> "") Then
If ((Mid$(Myno, 1, 3)) > 10) Then
MyThou = GetTxt + " الف"
Else
MyThou = GetTxt + " الاف"
If ((Mid$(Myno, 3, 1)) = 1) Then MyThou = " الف"
If ((Mid$(Myno, 3, 1)) = 2) Then MyThou = " الفان"
End If
End If

If (I = 9) And (GetTxt <> "") Then MyHun = GetTxt
If (I = 12) And (GetTxt <> "") Then MyFraction = GetTxt
End If

I = I + 3
Loop
'============================
If (Mybillion <> "") Then
If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd
End If

If (MyMillion <> "") Then
If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd
End If

If (MyThou <> "") Then
If (MyHun <> "") Then MyThou = MyThou + MyAnd
End If

If MyFraction <> "" Then
If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then
NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur
Else
NoToTxt2 = ReMark + MyFraction + " " + MySubCur
End If
Else
NoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur
End If

End Function

[/align:b5d967e570]

جزاك الله خيرا

مع اضافة السطر الاول

Dim MyArry1(0 To 9) As String

ابدعت

ماشاء الله عليك

 

شارك هذه المشاركه


رابط المشاركه
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زوار
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


  • محتوي مشابه

    • بواسطه waleed_isec
      تناقش هذه المحاضرة المواضيع التالية:
      ماهية علم السلوك التنظيمي, مدخل الى السلوك التنظيمي, مزيج السلوك التنظيمي
      المحاضرة الأولى:
      http://videos.najah.edu/node/27155
       
    • بواسطه رمضان عارف رمضان
      اتشرف بان اشارك منتداكم بهذا العمل المتواضع المتمثل في رسالة الماجستير الخاصة بي والتي تم مناقشتها في 13/11/2011 م وارجو من الله ان تكون مفيده لمن يدرس في هذا الموضوع ورجاء من حضراتكم ان تغفروا لي اي تقصير ستجدونه في هذا العمل فان كان به خيرا فمن الله وان كان به نقص او تقصير فذلك من نفسي
      رمضان عارف رمضان محروس - مدرس مساعد بقسم المحاسبة كلية التجارة جامعة جنوب الوادي
      دور لجان المراجعة في تفعيل حوكمة الشركات.pdf
    • بواسطه Bishara
      الأخوة الأفاضل
       
      لنفرض ان شركة تقوم بتربية الماشية وهناك مواليد من هذه الماشية السؤال ؟ كيف يتم تقيد المواليد الجدد في مخزون الشركة وعند بيع هذه المواليد كيف يتم بيع هذه المواليد ؟ ماهي المعالجة المحاسبية الصحيحة لهذا في مخزون الشركة وما هي القيود المحاسبية .......... أفيدوني
       
       
    • بواسطه mahmoud217
      هو الفرع الخاص بالذكاه مفيش تجاوب معاه ليه 
      ياريت لو حد عنده خبره بالزكاه يفيدنا 
      الخسائر المدوره كيفيه خصمها يعنى لو شركه افراد بتحقق خسائر الخسائر دى معدله وفقا لبنود المصلحه كيفيه خصمها
      ياريت يا اخوانى لو فيه كتاب للزكاه يكون به شرح وافى وحلات عمليه يحط الرابط جزاكم الله خيرا
    • بواسطه rana
      بسم الله الرحمن الرحيم هذا كتاب Financial Management طبعة 2005 الطبعة العاشرة ارجو الاستفادة منه للجميع اختكم في الله دعواتكم الصالحة
      0324289081financialmanagement.pdf
×
×
  • اضف...