:و: تفقيط فاتورة ؟

[egyman]

يا شباب أنا في ورطة مع الوقت

قمت بعمل شاشة تعمل كواجهة للفواتير و المطلوب مني الأن هو تفقيط الفاتورة

فهل أجد عندكم كود التفقيط

و لكم جزيل شكري

[سهل احمد العريشي]

بسم الله الرحمن الرحيم

أستعمل خاصية البحث

أخيك سهل احمد ( ابو نعيم )

[egyman]

شكراً أخي سهيل على الرد

و لكني كتبت كود للتفقيط و لكن المشكلة به :

أنه يكتب ثلاث مئة : أربع مئة

و كان المطلوب

أن يكتب

ثلاثمئة : أربعتمئة

المهم إني حصلت من أحد المنتديات على كود أفضل من الذي كتبته و هو :

v ضع هذا الكود فى حدث عند فقد التركيز لخانة المبلغ :

Private Sub s_LostFocus()

Me.تفقيط = B_Only(, 1, 0, 2, "ريال سعودي", "ريالات", 0, "هللة", "هللات", 4)

End Sub

v قم بإنشاء موديل جديد و انسخ به الكود التالي :

Option Compare Database

Option Explicit

Public Const vArabic As Byte = 1

Public Const vEnglish As Byte = 2

Public Const vMale As Byte = 0

Public Const vFemale As Byte = 1

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 = vArabic 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 S2Double(Single_ As Variant, Sex As Byte) As String

Dim LLeter As Integer

Dim k As Byte

Dim Sngl_1, Sngl_2 As String

k = InStr(1, Single_ & " ", " ")

Sngl_1 = Left(Single_, k - 1)

Sngl_2 = ""

If k < Len(Single_) Then

Sngl_2 = Mid(Single_, k + 1, Len(Single_))

End If

If Sngl_2 <> "" Then

If Right(Sngl_2, 1) = "ة" Then

Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان"

Else

Sngl_2 = Sngl_2 & "ان"

End If

End If

If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1))

Select Case LLeter

Case 201 ' "ة"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان"

Case 236 ' "ى"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان"

Case 199 ' "ا"

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

Case 193 ' "ء"

If Right(Sngl_1, 2) = "اء" Then

If Sex = 1 Then

Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان"

Else

Sngl_1 = Sngl_1 & "ان"

End If

End If

Case Else

If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان"

End Select

If Sngl_2 <> "" Then

S2Double = Sngl_1 & " " & Sngl_2

Else

S2Double = Sngl_1

End If

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 vMale:

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 vFemale:

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 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 ReFormat(InNum As Double, Dec As Byte) As Double

Dim NewFormat As String

If Dec > 0 Then NewFormat = "0." Else NewFormat = "0"

NewFormat = NewFormat & String(Dec, "0")

ReFormat = Format(InNum, NewFormat)

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

Function AOnly(Num_, FracS, Single_, Ploral_ As String, Parts, Sex, Dec As Byte) As String

Const And_ As String * 1 = "و"

Const Lang = vArabic

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 Sngl_1, Sngl_2 As String

Dim Female(1 To 10) As Variant

Dim Parts_(0 To 11) As String

If Val(Num_) = 0 Then

If FracS = "" Then

AOnly = RTrim("مسدد نقدي ")

Exit Function

Else

AOnly = FracS & " " & Single_

End If

Exit Function

End If

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) = "كدرليونات"

k = InStr(1, Single_ & " ", " ")

Sngl_1 = Left(Single_, k - 1)

Sngl_2 = ""

If k < Len(Single_) Then

Sngl_2 = Mid(Single_, k + 1, Len(Single_))

End If

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 = vMale

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(CByte(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, CByte(Sex), Female()) 'Sex

Case 3 To 19:

N3_ = Fmale(TempI, CByte(Sex), Female())

Case 20 To 99:

N2_ = Tens(CByte(N2), Female())

If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female())

If (N3 Mod 10 = 1) And (Sex = vFemale) 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, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang)

Case 3 To 10:

If Sngl_2 <> "" Then

If Right(Sngl_2, 1) = "ة" Then

Only_ = AddAnd(Only_, Ploral_, Sngl_2, "", Lang)

Else

Only_ = AddAnd(Only_, Ploral_, Sngl_2 & "ة", "", Lang)

End If

Else

Only_ = AddAnd(Only_, Ploral_, "", "", Lang)

End If

Case 11 To 99:

If Sngl_1 <> "" Then

Only_ = AddAnd(Only_, Sngl_1, "", "", Lang)

N1_ = Mid(Only_, Len(Only_), 1)

Select Case N1_

Case "ة", "ى", "ا"

Case Else

Only_ = Only_ + "ا"

End Select

N1_ = Mid(Only_, Len(Only_) - 2, 3)

'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2004/06/03

If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then

Only_ = Left(Only_, Len(Only_) - 1)

End If

If Sngl_2 <> "" Then

If Right(Only_, 1) = "ا" Then

Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang)

Else

Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

End If

Else

Only_ = AddAnd(Only_, Sngl_2, "", "", Lang)

End If

End If

End Select

Else

Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang)

End If

AOnly = (Only_)

End Function

Function EOnly(Num_, FracS, Single_ As String, Parts, Dec As Byte) As String

Const Lang = vEnglish

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

If Val(Num_) = 0 Then

If FracS = "" Then

EOnly = LTrim(Single_ & " zero")

Else

EOnly = Single_ & " " & FracS

End If

Exit Function

End If

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) = "forty"

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(CByte(N1), ESingle())

Select Case TempI

Case 1 To 12: N3_ = ESingle(TempI)

Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), 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)

EOnly = Only_

End If

End Function

Function S_Only(InNum As Variant, Lang, FracType As Byte) As Variant

Dim Num_ As String

Dim k, Dec As Byte

Dim FType As Byte

If IsNull(InNum) Then

S_Only = Null

Exit Function

End If

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

FType = FracType

If FType <> 2 Then FType = 1

S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType)

End Function

Function B_Only(InNum As Variant, Lang, Sex, Dec As Byte, Single_, Ploral_ As String, _

FSex As Byte, SFrac, PFrac As String, FracType As Byte) As Variant

Dim Leng, Parts, k As Byte

Dim FracVal As Double

Dim Num_ As String

Dim FracS As String

Dim FracNum As String

Dim Only As String

If IsNull(InNum) Then

B_Only = Null

Exit Function

End If

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 = ""

FracNum = Trim(Mid(FracS, 3, Len(FracS)))

If FracS <> "" Then

Select Case FracType

Case 2

Select Case Lang

Case vArabic: FracS = "1" & String(Dec, "0") & "/" & Format(FracNum, String(Dec, "0"))

Case vEnglish: FracS = Format(FracNum, String(Dec, "0")) & "/" & "1" & String(Dec, "0")

End Select

Case 3

FracS = FracNum & " " & SFrac

If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "'s"

Case 4

Leng = Len(FracNum)

Parts = Fix((Leng + 2) / 3)

For k = 1 To (Parts * 3) - Leng

FracNum = Insert("0", FracNum, 1)

Next k

Select Case Lang

Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType)

Case vEnglish: FracS = EOnly(FracNum, "", "", Parts, 0) & " " & SFrac

If CDbl(FracNum) > 1 Then FracS = FracS & "'s"

End Select

End Select

End If

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 FracType

Case 1, 2

Select Case Lang

Case vArabic: Only = AOnly(Num_, FracS, Single_, Ploral_, Parts, Sex, Dec)

Case vEnglish: Only = EOnly(Num_, FracS, Single_ & "", Parts, Dec)

End Select

Case 3, 4

Select Case Lang

Case vArabic: Only = AOnly(Num_, "", Single_, Ploral_, Parts, Sex, Dec)

If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

If FracS <> "" Then Only = AddAnd(Only, FracS, "", "و ", CByte(Lang))

Case vEnglish: Only = EOnly(Num_, "", Single_ & "", Parts, Dec)

If CDbl(Num_) = 0 And FracS <> "" Then Only = ""

If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang))

End Select

End Select

If Only <> "" Then

Select Case Lang

Case vArabic: B_Only = "فقط " & Only

Case vEnglish: B_Only = Only & " only"

End Select

End If

End Function

أرجوا أن يستفيد منه الجميع و لا تنسوا صاحب الكود من الدعاء

[سهل احمد العريشي]

بسم الله الرحمن الرحيم

جزاك الله خيرا وصاحب الكود وشكرا لك على وضعك الحل حتى يستفيد الآخرين وهذا هو المطلوب من الجميع فقد يكون هنالك من لديه موضوع مشابه وفي انتظار الحل وعندما يجد عضوا الحل لمشكلته في اي مكان آخر ويضعها ليستفيد منها الآخرين فهذا دليل على حب الخير وصفه من صفات المؤمنيين بارك الله فيك وزادك علما ونورا

أخيك سهل احمد ( ابو نعيم )