طريقة بسيطة مقتبسة لتحويل المبالغ من الأرقام الى حروف

السلام عليكم و رحمة الله و بركاته صيام مقبول و عمل متقبل ان شاء الله
الى من يهمه أمر تحويل المبالغ من الأرقام الى حروف و يجيد استعمال الوحدات النمطية في الأكسس و الاكسل أن يتفضل بهذه التعليمات البرمجية المقتبسة.الآتية بالعربية و الفرنسية:





Function
Convertar(g As Double) As String


If g <= 0 Or Not (IsNumeric(g)) Then


Convertar = "لاشـــــيء"


Exit Function


End If


g = CVar(Int(g * 10 ^ 2 + 0.511) / 10 ^ 2)


Dim NBR, u, d, c, v, w, centa, sepcd, diza,
sepdu, uni, decim


Dim unites, jr, result, n


ReDim L(17) As String, x(10) As String


L(1) = " واحد": L(2) = " اثنان":
L(3) = " ثلاثة": L(4) = " اربعة"


L(5) = " خمسة": L(6) = " ستة": L(7) = " سبعة":
L(8) = " ثمانية"


L(9) = " تسعة": L(10) = " عشرة"


L(13) = " ثلاثة عشر": L(14) = " اربعة عشر":
L(15) = " خمسة عشر": L(16) = " ستة
عشر"


x(1) = "عشرة": x(2) = " عشرون ":
x(3) = " ثلاثون ": x(4) = " اربعون "


x(5) = " خمسون ": x(6) = " ستون ":
x(7) = " سبعون "


x(8) = " ثمانون ": x(9) = " تسعون "


'******************************


NBR = Format(g,
"000000000000.00")


mil = Val(Mid(NBR, 1, 3))


mll = Val(Mid(NBR, 4, 3))


ml = Val(Mid(NBR, 7, 3))


jr = Val(Mid(NBR, 10, 3))


unites = Val(Mid(NBR, 14, 2))


result = ""


If mil <> 0 Then


If mil > 0 Then


n = mil


End If


GoSub Tranche1


If mil > 0 Then


If
mil > 0 And mll = 0 And ml = 0 Then


result
= result + re + " مليار"


Else


result
= result + re + " مليار و"


End
If


End If


End If


If mll <> 0 Then


If mll > 0 Then


n = mll


End If


GoSub Tranche1


If mll > 0 Then


If
mll > 0 And ml = 0 And jr = 0 Then


result
= result + re + " مليون"


Else


result
= result + re + " مليون و"


End
If


End If


End If


If ml <> 0 Then


If ml > 0 Then


n = ml


End If


End If


GoSub Tranche1


If ml
= 1 Then


If ml
= 1 And jr = 0 Then


result = result + " الف"


Else


result = result + " الف و"


End If


End If


If ml
> 2 And ml < 11 Then


If ml
> 2 And jr = 0 Then


result = result + re + " الاف"


Else


result = result + re + " الاف و"


End
If


End If


If ml > 2 And ml >= 11 Then


If ml
> 2 And jr = 0 Then


result = result + re + " الف"


Else


result = result + re + " الف و"


End
If


End If


If ml
= 2 Then


If ml
= 2 And jr = 0 Then


result = result + " لفان"


Else


result = result + " الفان و"


End If


End If


Convertar = LTrim(RTrim(result))


n = decim


If jr >= 0 Then


' If jr > 0 Then


n = jr


' End If


GoSub Tranche1


If jr > 0 And unites > 0 Then


result = result + re + " دينار و"


ElseIf jr = 0 And unites > 0 Then


result = result + "" + re +
""


ElseIf jr > 0 And unites = 0 Then


result = result + "" + re +
" دينار"


ElseIf jr = 0 And unites = 0 Then


result = result + "" + re +
" دينار"


'End If


End If


End If


n = unites


GoSub Tranche1


result = result + re + ""





If unites <> 0 Then


If unites > 0 Then


n = unites


End If


GoSub Tranche1


result = result + " سنتيم"


Else


If unites <> 0 Then


n = unites


End If


GoSub Tranche1


result = result + " جزائري"


End If


Convertar = LTrim(result)


Exit Function


Tranche1:


n = Format(n, "000.00")


c = Val(Left(n, 1))


d = Val(Mid(n, 2, 1))


u = Val(Mid(n, 3, 1))


v = Val(Mid(n, 5, 1))


w = Val(Mid(n, 6, 1))


centa = "": sepcd = "":
decim = ""


diza = "": sepdu = "": uni
= "":





If c > 1 Then centa = ""


If c > 0 Then


If c = 2 Then


If c = 2 And d = 0 And u = 0 Then


sepcd = " مئتان"


Else


sepcd = " مئتان و"


End If





ElseIf c = 3 Then


If c = 3 And d = 0 And u = 0 Then


sepcd = " ثلاثمائة"


Else


sepcd = " ثلاثمائة و"


End If


ElseIf c = 4 Then


If c = 4 And d = 0 And u = 0 Then


sepcd = " اربعمائة"


Else


sepcd = " اربعمائة و"


End If


ElseIf c = 5 Then


If c = 5 And d = 0 And u = 0 Then


sepcd = " خمسمائة"


Else


sepcd = " خمسمائة و"


End If


ElseIf c = 6 Then


If c = 6 And d = 0 And u = 0 Then


sepcd = " ستمائة"


Else


sepcd = " ستمائة و"


End If


ElseIf c = 7 Then


If c = 7 And d = 0 And u = 0 Then


sepcd = " سبعمائة"


Else


sepcd = " سبعمائة و"


End If


ElseIf c = 8 Then


If c = 8 And d = 0 And u = 0 Then


sepcd = " ثمانمائة"


Else


sepcd = " ثمانمائة و"


End If


ElseIf c = 9 Then


If c = 9 And d = 0 And u = 0 Then


sepcd = " تسعمائة"


Else


sepcd = " تسعمائة و"


End If


ElseIf c > 0 And d = 0 And u =
0 Then


sepcd = " مائـة"


Else


sepcd = " مائة و"


End If


End If


If (u >= 3) Then


uni = "" + L(u)


End If


If u = 1 And d = 1 Then


uni = "" + " احدى "


ElseIf u = 2 And d = 1 Then uni =
"" + " اثنا"


Else


uni = "" + L(u)


End If





If d > 1 And u > 0 Then


diza = "" + " و" + x(d)


Else


diza
= "" + x(d)


End If


re
= centa + sepcd + uni + diza


Return


End
Function


الفرنسية:






Function
convertfr(g As Double) As String





If g <= 0 Or Not (IsNumeric(g)) Then


convertfr = "ZERO"


Exit Function


End If


g
= CVar(Int(g * 10 ^ 2 + 0.511) / 10 ^ 2)


Dim NBR, u, d, c, v, w, centa, sepcd, diza,
sepdu, uni, decim


Dim unites, jr, result, n


ReDim l(17) As String, x(10) As String


l(1)
= "Un ": l(2) = "Deux ": l(3) = "Trois ": l(4) =
"Quatre "


l(5) = "Cinq ": l(6) = "Six
": l(7) = "Sept ": l(8) = "Huit "


l(9) = "Neuf ": l(10) = "Dix
": l(11) = "Onze ": l(12) = "Douze "


l(13) = " Treize ": l(14) =
" Quatorze ": l(15) = " Quinze ": l(16) = " Seize
"


x(1) = "Dix ": x(2) = "Vingt
": x(3) = "Trente ": x(4) = "Quarante "


x(5) = "Cinquante ": x(6) =
"Soixante ": x(7) = "Soixante- Dix "


x(8) = "Quatre- Vingts ": x(9) = "Quatre- Vingt- Dix "





'******************************





NBR = Format(g, "000000000.00")


mll = Val(Mid(NBR, 1, 3))


ml = Val(Mid(NBR, 4, 3))


jr = Val(Mid(NBR, 7, 3))


unites = Val(Mid(NBR, 11, 2))


result = ""


If mll <> 0 Then


If mll > 0 Then


n = mll


End If


GoSub Tranche


result = result + re + "Million
"


Else


If mll = 0 Then


n = mll


End If


GoSub Tranche


result = result + re + " "


End If


If ml <> 0 Then


If ml > 0 Then


n = ml


End If


GoSub Tranche


If ml
= 1 Then


result = result + "Mille "


Else


result = result + re + "Mille "


End
If


Else


If ml = 0 Then


n = ml


End If


GoSub Tranche


result = result + ""


End If


n
= decim


If
mll <> 0 Or ml <> 0 Or jr <> 0 Then


' If mll > 0 Or ml > 0 Or jr > 0 Then


If mll >= 0 Or ml >= 0 Or jr >= 0
Then


n = jr


End If


GoSub Tranche


result = result + re + "Dinars "


Else


If jr = 0 Then


n
= jr


End If


GoSub Tranche


result = result + re + ""


End If


n = unites


GoSub Tranche


result = result + re + ""


If unites <> 0 Then


If unites > 0 Then


n = unites


End If


GoSub Tranche


result = result + "Centimme(s). "


Else


If unites = 0 Then


n = unites


End If


GoSub Tranche


result = result + "Algériennes
"


End
If


convertfr = LTrim(result)


Exit Function


Tranche:


n = Format(n, "000.00")


c = Val(Left(n, 1))


d = Val(Mid(n, 2, 1))


u = Val(Mid(n, 3, 1))


v = Val(Mid(n, 5, 1))


w = Val(Mid(n, 6, 1))


centa = "": sepcd = "":
decim = ""


diza
= "": sepdu = "": uni = "":


re = ""


centa = "": sepcd = ""


diza = "": sepdu = "": uni =
""


If c >= 2 Then centa = " " +
l(c)


If c > 0 Then


If c >= 1 Then


sepcd = "Cent "





End If


End If


If (u = 1) And (2 <= d) And (d <= 7)
Then


sepdu = " Et"


Else


sepdu = ""


End If


If (u > 0) Then


If u <= 6 Then


If (d = 1) Or (d = 7) Or (d = 9)
Then


d = d - 1: u = u + 10


End If


End If


uni = " " + l(u)


Else


uni = ""


End If


If d > 0 Then


diza = " " + x(d)


If (d = 8) And (u = 0) Then


diza = " Quatre Vingts "


End If


End If


re = centa + sepcd + diza + sepdu + uni


Return

End Function

بارك الله فيك أخي

أرجو أن تعمل معي مع أكسس لأني بحاجة ماسة إليه

كما أود أن تفسر لنا الطريقة مع أكسس أو إكسل

رمضان كريم

بارك الله فيك أخي

أرجو أن تعمل معي مع أكسس لأني بحاجة ماسة إليه

كما أود أن تفسر لنا الطريقة مع أكسس أو إكسل

رمضان كريم

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

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

أنا لم أتمكن من نسخ الملف لإستعماله في تحويل الأرقام إلى حروف كيف يمكن نسخ هذا الملف

بارك الله فيك وشكرا

من فضلك هل يمكن أن نضع المثال في ملف أكسس لتسهيل المهمة لأني لم أستطع وضع الكود