طلب كود تفقيط

[alowa]

السلام عليكم ورحمه الله وبركاته: ارجو من السادة الافاضل كود لتفقيط الاقام وليست العملات في الاكسس يعني عندي مثلا حقل به الكميه وحقل اخر عاوز يظهر فيه الكميه بالحروف فقط بدون عملات يعني مثلا 2.5 يظهر بالشكل دة اثنين ونصف من المائه فقط لاغير او من الالف علي حسب الكمية المدخله وهذ في النموذج طبعا وكيفيه كتابه الكود في الحقل المراد تفقيطه

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

تم تعديل نوفمبر 23, 2018 بواسطه alowa

[Ali Mohamed Ali]

وعليكم السلام تفضل هذا الكود

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

 

[Ali Mohamed Ali]

وهذا ملف أخر به كود اخر

.

 

تحويل الارقام الى حروف.mdb

[alowa]

جزاك الله كل خير علي جهدك واهتمامك ولكن انا اريد تفقيط الارقام انا مثلا بدخل عندي وحدات بالمتر وبالكيلو وارقام صحيحه وكسور مثلا 5.5 اريدها تكتب بالطريقة الصحيحه عاوز تطلع الرقم وبعدين الكسر مثلا خمسه وخمسه من عشره او من مائه او من الف فقط لاغير ياريت لو فيه تعديل علي الموديول او لو فيه موديول اخر يخدم طلبي اكون شاكر لحضرتك

والسلام عليكم