هل يمكن باكسس تحويل الأرقام الي ارقام حروف مثل رقم ( 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]
[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]
السلام عليكم ورحمه الله وبركاته اضافة رائعة ولو ممكن توضح لنا طريقة التحويل فى الاكسيل
هذا برنامج بالاكسس للتفقيط منقووول
____144.rar (23 KB)
إعجاب واحد (1)
" قَالُوا سُبْحَانَكَ لَا عِلْمَ لَنَا إِلَّا مَا عَلَّمْتَنَا إِنَّكَ أَنْتَ الْعَلِيمُ الْحَكِيمُ"
شكراً جزيلاً
السلام عليكم ورحمة الله وبركاته
بصراحة الموضوع جميل جدا ويستحق الاهتمام،، أنا الآن عملت برنامج عن طريق الاكسس يخص المحاسبة لكن أرغب في أن يكون التفقيط بالاحرف عن طريق البرنامج مثل طلب الاخ عزيز وأيضاً أنا مبتديء وأريد الشرح بالتفصيل ،، فضلاً لا أمرا طبعا
وتحياتي للجميع
شكرا جزيلا
على هذا الموضوع القيم ولكن للإستفادة أكثر
أرجو أن تزودينا بكود حول كيفية تحويل التاريخ إلى نص
السلام عليكم ورحمة الله وبركاته
بصراحة الموضوع جميل جدا ويستحق الاهتمام،، جزاكم الله خيرا
وتحياتي للجميع
مشكووووووووووووووووووووووور
الشكر الجزيل لهذا الموضوع , جزاكم الله كل الخير
الف شكر
مشكور
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 StringDim MyArry2(0 To 9) As StringDim MyArry3(0 To 9) As StringDim Myno As StringDim GetNo As StringDim RdNo As StringDim My100 As StringDim My10 As StringDim My1 As StringDim My11 As StringDim My12 As StringDim GetTxt As StringDim Mybillion As StringDim MyMillion As StringDim MyThou As StringDim MyHun As StringDim MyFraction As StringDim MyAnd As StringDim I As IntegerDim ReMark As StringIf TheNo > 999999999999.999 Then Exit FunctionIf TheNo < 0 ThenTheNo = TheNo * -1ReMark = "لم يتبقي "ElseReMark = "فقط "End IfIf TheNo = 0 ThenNoToTxt2 = "صفر"Exit FunctionEnd IfMyAnd = " و"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 < 16If I < 12 ThenMyno = Mid$(GetNo, I + 1, 3)ElseMyno = 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 <> “”) ThenIf (MyMillion <> “”) Or (MyThou <> “”) Or (MyHun <> “”) Then Mybillion = Mybillion + MyAndEnd IfIf (MyMillion <> “”) ThenIf (MyThou <> “”) Or (MyHun <> “”) Then MyMillion = MyMillion + MyAndEnd IfIf (MyThou <> “”) ThenIf (MyHun <> “”) Then MyThou = MyThou + MyAndEnd IfIf MyFraction <> “” ThenIf (Mybillion <> “”) Or (MyMillion <> “”) Or (MyThou <> “”) Or (MyHun <> “”) ThenNoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCurElseNoToTxt2 = ReMark + MyFraction + " " + MySubCurEnd IfElseNoToTxt2 = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCurEnd IfEnd Function
[/align:b5d967e570]
جزاك الله خيرا
مع اضافة السطر الاول
Dim MyArry1(0 To 9) As String
ابدعت
ماشاء الله عليك