السادة الكرام
بعد التحية
هذا التفقيط كتبته بالباسكال منذ سنوات وقد أتعبني تحويله للاختلاف الكبير بين اللغتين فعذرا ان كان هناك عدم تنسيق أو وجود متغيرات غير مستخدمة فبكل صراحة الباسكال لغة ممتازة جدا والتحكم بها أفضل من البيسك بكثير
عموما نحتاج لعمل جدول كالآتي "اختياري" :
Field Name Data Type Field Size Descriptin
CurID Number Integer كود المعدود
Sex Number Byte جنس المعدود
Dec Number Byte طول الكسر
ASingle Text 15 مفرد المعدود بالعربي
ADouble Text 15 مثنى المعدود بالعربي
APloral Text 15 جمع المعدود بالعربي
ESingle Text 15 مفرد المعدود بالإنجليزي
ثم كتابة الآتي في module
Option Compare Database
Option Explicit
Dim Lang As Byte
Function Delete(S As String, Index, Count As Integer) As String
Delete = Left(S, Index - 1) + _
Mid(S, Index + Count, Len(S))
End Function
Function Insert(Source, S As String, Index As Integer) As String
Dim LPart, RPart As String
LPart = Left(S, Index - 1)
RPart = Mid(S, Index, Len(S))
Insert = LPart & Source & RPart
End Function
Function AddAnd(S1, S2, S3, And_ As String, Lang As Byte) As String
Dim InAnd_, CollectS As String
If Lang = 1 Then InAnd_ = " " + And_ Else InAnd_ = And_ + " "
If (S1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = ""
CollectS = S1 + And_ + S2
If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = ""
AddAnd = CollectS + And_ + S3
End Function
Function FMale(Num, Sex As Byte, FeMale()) As String
Dim Two(1 To 4) As String
Dim InSex As Byte
Two(1) = "أحد"
Two(2) = "اثنان"
Two(3) = "إحدى"
Two(4) = "ة"
Select Case Sex
Case 0:
Select Case Num
Case 1: FMale = Mid(FeMale(1), 1, 4)
Case 2: FMale = Two(2)
Case 8: FMale = FeMale(Num) + "ي" + Two(4)
Case 3 To 7, 9, 10: FMale = FeMale(Num) + Two(4)
Case 11: FMale = Two(1) + " " + FeMale(10)
Case 12: FMale = Mid(Two(2), 1, 4) + " " + FeMale(10)
Case 13 To 19: FMale = FeMale(Num - 10) + Two(4) + " " + FeMale(10)
End Select
Case 1:
Select Case Num
Case 1 To 10: FMale = FeMale(Num)
Case 11: FMale = Two(3) + " " + FeMale(10) + Two(4)
Case 12: FMale = Mid(FeMale(2), 1, 5) + " " + FeMale(10) + Two(4)
Case 13 To 19: FMale = FeMale(Num - 10) + " " + FeMale(10) + Two(4)
End Select
End Select
End Function
Function Tens(Num As Byte, FeMale()) As String
Const Noon = "ون"
Select Case Num
Case 2: Tens = FeMale(10) + Noon
Case 3 To 9: Tens = FeMale(Num) + Noon
End Select
End Function
Function Hunds(Num As Byte, FeMale()) As String
Const Hund = "مائة"
Select Case Num
Case 1: Hunds = Hund
Case 2: Hunds = Mid(Hund, 1, 3) + Mid(FeMale(2), 4, 3)
Case 3 To 9: Hunds = FeMale(Num) + Hund
End Select
End Function
Function AOnly(Num_, FracS, Single_, Double_, Ploral_ As String, Parts, Sex, Dec As Byte) As String
Const And_ As String * 1 = "و"
Const Lang = 1
Dim PartNum(0 To 5) As Long
Dim Result1(0 To 5) As String
Dim N1, N2, N3, TempI, Sex2, K As Byte
Dim Only_ As String
Dim OnlyPart As String
Dim N1_, N2_ As String
Dim N3_ As String
Dim Part_ As String
Dim TempS As String
Dim FeMale(1 To 10) As Variant
Dim Parts_(0 To 11) As String
FeMale(1) = "واحدة"
FeMale(2) = "اثنتان"
FeMale(3) = "ثلاث"
FeMale(4) = "أربع"
FeMale(5) = "خمس"
FeMale(6) = "ست"
FeMale(7) = "سبع"
FeMale(8) = "ثمان"
FeMale(9) = "تسع"
FeMale(10) = "عشر"
Parts_(0) = ""
Parts_(1) = "ألف"
Parts_(2) = "مليون"
Parts_(3) = "مليار"
Parts_(4) = "ترليون"
Parts_(5) = "كدرليون"
Parts_(6) = ""
Parts_(7) = "آلاف"
Parts_(8) = "ملايين"
Parts_(9) = "مليارات"
Parts_(10) = "ترليونات"
Parts_(11) = "كدرليونات"
For K = 0 To Parts - 1
PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
Next K
Sex2 = Sex
For K = 0 To (Parts - 1)
If K = (Parts - 1) Then Sex = Sex2 Else Sex = 0
TempS = Mid(Num_, (K * 3) + 1, 3)
TempI = Val(Mid(TempS, 2, 2))
N1 = Val(Mid(TempS, 1, 1))
N2 = Val(Mid(TempS, 2, 1))
N3 = Val(Mid(TempS, 3, 1))
'{------------------------------------------}
N1_ = "": N2_ = "": N3_ = ""
If N1 > 0 Then N1_ = Hunds(Nz(N1), FeMale())
If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1)
Select Case TempI
Case 1 To 2:
If K = Parts - 1 Then If FracS <> "" Then N3_ = FMale(N3, Sex * 1, FeMale()) 'Sex
Case 3 To 19:
N3_ = FMale(TempI, Sex * 1, FeMale())
Case 20 To 99:
N2_ = Tens(Nz(N2), FeMale())
If N3 > 0 Then N3_ = FMale(N3, Sex * 1, FeMale())
If (N3 Mod 10 = 1) And (Sex = 1) Then N3_ = "إحدى"
End Select
OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang)
'{------------------------------------------}
If PartNum(K) > 100 Then
Select Case TempI
Case 1, 2:
OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang)
End Select
End If
'{------------------------------------------}
Part_ = ""
If PartNum(K) > 0 Then
Part_ = Parts_(Parts - K - 1)
If Part_ <> "" Then
Select Case TempI
Case 2: Part_ = Part_ + "ان"
Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 6)
Case 11 To 99: Part_ = Part_ + "ا"
End Select
End If
End If
'{------------------------------------------}
If Part_ <> "" Then
If TempI >= 1 And TempI <= 2 Then
OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang)
Else
OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang)
End If
End If
Result1(K) = (OnlyPart)
Next K
'{------------------------------------------}
N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang)
N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang)
Only_ = AddAnd(N1_, N2_, "", And_, Lang)
If FracS <> "" Then
If Only_ <> "" Then FracS = " " + FracS
Only_ = AddAnd(Only_, FracS, "", And_, Lang)
End If
If Only_ <> "" Then
If Mid(Only_, Len(Only_), 1) = "ا" Then
If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then
Only_ = Mid(Only_, 1, Len(Only_) - 1)
End If
End If
If TempS = "000" Then
If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then
Only_ = Mid(Only_, 1, Len(Only_) - 1)
End If
End If
End If
'{------------------------------------------}
If FracS = "" Then
Select Case TempI
Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang)
Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, FMale(1, Sex * 1, FeMale()), "", "", Lang), "", And_, Lang)
Case 2: Only_ = AddAnd(Only_, AddAnd(Double_, FMale(2, Sex * 1, FeMale()), "", "", Lang), "", And_, Lang)
Case 3 To 10: Only_ = AddAnd(Only_, Ploral_, "", "", Lang)
Case 11 To 99:
If Single_ <> "" Then
Only_ = AddAnd(Only_, Single_, "", "", Lang)
N1_ = Mid(Only_, Len(Only_) - 1, 2)
N2_ = Mid(Only_, Len(Only_), 1)
If (N1_ <> "اء") And (N2_ <> "ة") And (N2_ <> "ى") And (N2_ <> "ا") Then
Only_ = Only_ + "ا"
End If
End If
End Select
Else
Only_ = AddAnd(Only_, Single_, "", "", Lang)
End If
If Only_ <> "" Then Only_ = "فقط " + Only_
AOnly = (Only_)
End Function
Function Tenteen(Num As Byte, ETens()) As String
Const een = "een"
Num = Num Mod 10
Select Case Num
Case 3 To 9:
Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een
End Select
End Function
Function EHunds(Num As Byte, ESingle()) As String
EHunds = ESingle(Num) + " hundred"
End Function
Function S_Only(InNum As Double, Lang As Byte) As String
Dim Num_ As String
Dim K, Dec As Byte
Num_ = Str(InNum)
K = InStr(1, Num_, ".", 1)
If K > 0 Then
Dec = Len(Num_) - K
If Dec < 2 Then Dec = 2
Else
Dec = 0
End If
S_Only = B_Only(InNum, Lang, 0, Dec, "", "", "")
End Function
Function M_Only(InNum As Double, Lang, CurID As Byte) As String
Dim dbs As Database
Dim rst As Recordset
Dim Sex, Dec As Byte
Dim S, D, P As String
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("Currencies", dbOpenDynaset)
If rst.RecordCount = 0 Then
M_Only = M_Only = S_Only(InNum, Lang * 1)
GoTo ExitSub
End If
With rst
.FindFirst "CurID Like '" & CurID & "'"
If Not .NoMatch Then
Sex = !Sex
Dec = !Dec
Select Case Lang
Case 1: S = !ASingle: D = !ADouble: P = !APloral
Case 2: S = !ESingle: D = "": P = ""
End Select
M_Only = B_Only(InNum, Lang, Sex, Dec, S, D, P)
Else
M_Only = S_Only(InNum, Lang * 1)
End If
End With
ExitSub:
rst.Close
Set dbs = Nothing
End Function
Function EOnly(Num_, FracS, Single_ As String, Parts, Dec As Byte) As String
Const Lang = 2
Dim ESingle(1 To 12) As Variant
Dim ETens(2 To 9) As Variant
Dim EParts_(0 To 5) As String
Dim TempS As String
Dim N1, N2, N3, TempI, Sex2 As Byte
Dim N1_, N2_, N3_ As String
Dim OnlyPart, Part_, Only_ As String
Dim Leng, K As Integer
Dim PartNum(0 To 5) As Long
Dim Result1(0 To 5) As String
ESingle(1) = "one"
ESingle(2) = "two"
ESingle(3) = "three"
ESingle(4) = "four"
ESingle(5) = "five"
ESingle(6) = "six"
ESingle(7) = "seven"
ESingle(8) = "eight"
ESingle(9) = "nine"
ESingle(10) = "ten"
ESingle(11) = "eleven"
ESingle(12) = "twelve"
ETens(2) = "twenty"
ETens(3) = "thirty"
ETens(4) = "fourty"
ETens(5) = "fifty"
ETens(6) = "sixty"
ETens(7) = "seventy"
ETens(8) = "eighty"
ETens(9) = "ninety"
EParts_(0) = ""
EParts_(1) = "thousund"
EParts_(2) = "million"
EParts_(3) = "billion"
EParts_(4) = "trillion"
EParts_(5) = "quadrillion"
For K = 0 To Parts - 1
PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3))
Next K
For K = 0 To (Parts - 1)
TempS = Mid(Num_, (K * 3) + 1, 3)
TempI = Val(Mid(TempS, 2, 2))
N1 = Val(Mid(TempS, 1, 1))
N2 = Val(Mid(TempS, 2, 1))
N3 = Val(Mid(TempS, 3, 1))
'{------------------------------------------}
N1_ = "": N2_ = "": N3_ = ""
If N1 > 0 Then N1_ = EHunds(Nz(N1), ESingle())
Select Case TempI
Case 1 To 13: N3_ = ESingle(TempI)
Case 14 To 19: If N3 > 0 Then N3_ = Tenteen(TempI + 0, ETens())
Case 20 To 99:
N2_ = ETens(N2)
If N3 > 0 Then
N3_ = N2_ + "-" + ESingle(N3)
N2_ = ""
End If
End Select
OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang)
'{------------------------------------------}
Part_ = ""
If PartNum(K) > 0 Then
Part_ = EParts_(Parts - K - 1)
If Part_ <> "" Then Part_ = EParts_((Parts - K - 1))
End If
Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang)
Next K
'{------------------------------------------}
N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang)
N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang)
Only_ = AddAnd(N1_, N2_, "", "", Lang)
Leng = Len(Only_)
Only_ = AddAnd(Only_, FracS, "", " and", Lang)
If Only_ <> "" Then
Only_ = AddAnd(Single_, Only_, "", "", Lang)
If Only_ <> "" Then Only_ = Only_ + " only"
EOnly = Only_
End If
End Function
Function ReFormat(InNum As Double, Dec As Byte) As Double
Dim NewFormat As String
Dim K As Byte
If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"
For K = 1 To Dec
NewFormat = NewFormat + "0"
Next K
ReFormat = Format(InNum, NewFormat)
End Function
Function B_Only(InNum As Double, Lang, Sex, Dec As Byte, Single_, Double_, Ploral_ As String) As String
Dim Leng, Parts, K As Byte
Dim FracVal As Double
Dim Num_ As String
Dim FracS As String
Num_ = Str(InNum)
If InStr(1, Num_, "E+", 1) > 0 Then
Num_ = ReStr(Num_)
FracVal = 0
GoTo DoProcess
End If
Num_ = ReFormat(Val(InNum), Dec)
K = InStr(1, Num_, ".", 1)
If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = ""
FracVal = Val(FracS)
Num_ = Trim(Str(Fix(InNum)))
Do While Len(FracS) < Dec + 2
FracS = Insert(FracS, "0", 1)
Loop
DoProcess:
If FracVal = 0 Then FracS = ""
Leng = Len(Num_)
Parts = Fix((Leng + 2) / 3)
For K = 1 To (Parts * 3) - Leng
Num_ = Insert("0", Num_, 1)
Next K
If Len(Num_) > 18 Then
B_Only = InNum
Exit Function
End If
Select Case Lang
Case 1: B_Only = AOnly(Num_, FracS, Single_, Double_, Ploral_, Parts, Sex, Dec)
Case 2: B_Only = EOnly(Num_, FracS, Single_ + "", Parts, Dec)
End Select
End Function
Function ReStr(InNum As String) As String
Dim K, Digits As Byte
Dim Num_ As String
Num_ = LTrim(InNum)
K = InStr(1, Num_, "E+", 1)
If K > 0 Then
Digits = Val(Mid(Num_, K + 2, 3))
Num_ = Left(Num_, K - 1)
Num_ = Delete(Num_, 2, 1)
Do While Len(Num_) - 1 < Digits
Num_ = Insert(Num_, "0", 1)
Loop
End If
ReStr = Num_
End Function
Sub Test()
'اللغة 1=عربي 2=انجليزي
' الجنس 0=مذكر 1=مؤنث
'الدالة الأولى
'المدخلات الرقم واللغة
MsgBox S_Only(3, 1)
'--------------------------------------------------
'الدالة الثانية
'"المدخلات الرقم واللغة و "كود المعدود .. موجود في جدول العملات
MsgBox M_Only(2, 1, 1)
'--------------------------------------------------
'الدالة الثالثة
'"المدخلات الرقم واللغة والجنس وطول الكسر و "مفرد،مثنى،جمع المعدود
MsgBox B_Only(3, 1, 0, 2, "ريال", "ريالان", "ريالات")
MsgBox B_Only(3, 1, 1, 2, "ليرة", "ليرتان", "ليرات")
End Sub
واستخدامه موضح في نهاية الـ module بثلاثة أشكال
أرجو أن يحوز على رضاكم
