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

aziz77 · 7 يونيو 2006

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

webmaster · 13 يونيو 2006

أخي الكريم

هذا الكود يحول من الأرقام إلى الحروف و لكن باللغة الأنجليزية و هو بالطبع بلغة الفيجوال بيسك للتطبيقات المرفقة مع قواعد بيانات أكسس و يمكنك وضع الكود في 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]

تم تعديل 12 أغسطس 2010 بواسطة admin

ATEF SOLIMAN · 4 أغسطس 2006

[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]

moatazezat · 11 فبراير 2007

السلام عليكم ورحمه الله وبركاته اضافة رائعة ولو ممكن توضح لنا طريقة التحويل فى الاكسيل

brownknight6 · 2 مارس 2007

هذا برنامج بالاكسس للتفقيط منقووول

____144.rar

sa2000 · 1 ديسمبر 2007

" قَالُوا سُبْحَانَكَ لَا عِلْمَ لَنَا إِلَّا مَا عَلَّمْتَنَا إِنَّكَ أَنْتَ الْعَلِيمُ الْحَكِيمُ"

شكراً جزيلاً

shafi · 10 مايو 2009

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

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

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

أبونصر الله · 19 فبراير 2010

شكرا جزيلا

على هذا الموضوع القيم ولكن للإستفادة أكثر

أرجو أن تزودينا بكود حول كيفية تحويل التاريخ إلى نص

احمد الرازي · 20 فبراير 2010

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

بصراحة الموضوع جميل جدا ويستحق الاهتمام،، جزاكم الله خيرا

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

amrrbacos · 9 مارس 2010

مشكووووووووووووووووووووووور

ammaree · 24 مارس 2010

الشكر الجزيل لهذا الموضوع , جزاكم الله كل الخير

ahmed mahfuz · 5 سبتمبر 2010

الف شكر

جي اي اس · 22 سبتمبر 2010

مشكور

تم تعديل 22 سبتمبر 2010 بواسطة ashrafabdulwahed
تكرار الحروف

jamal_faiye · 12 مارس 2019

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

ابدعت

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

تسجيل دخول

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

Recommended Posts

aziz77

webmaster

ATEF SOLIMAN

moatazezat

brownknight6

sa2000

shafi

أبونصر الله

احمد الرازي

amrrbacos

ammaree

ahmed mahfuz

جي اي اس

jamal_faiye

انشئ حساب جديد أو قم بتسجيل دخولك لتتمكن من إضافة تعليق جديد

انشئ حساب جديد

تسجيل دخول

محتوى مشابه

الهيكل التنظيمي في السلم الاداري

دور لجان المراجعة في تفعيل حوكمة الشركات دراسة نظرية وتطبيقية

المعالجة المحاسبية لنشاط شركات الماشية و الثروة الحيوانية

استفسار عن معالجة الخسائر المعدله وفقا لبنود مصلحه الزكاة و كيفيه خصمها

كتاب ادارة مالية متقدمة 1 2 3 4 6

استعراض

مجلة محاسبة دوت نت

النشاطات