اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

دالة التفقيط

محب العقيدة

بواسطه محب العقيدة
في قسم الأكسيس Access

 مشاركة

الردود الموصى بها

محب العقيدة

محب العقيدة

قام بنشر
قام بنشر

السلا عليكم 

هناك وحدة نمطية واحدة  لتفقيط لاكثر من عملة وحسب عدد الخانات كالموجودة في فيديو قناة a soft

https://www.youtube.com/watch?v=RSIAgsq3ZDY

لكن للاسف رابط الملف لا يعمل.

احببت ان اطلع عليها  لو تكرم احد الاخوة الذي يملك الملف برفعه

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

رابط هذا التعليق
شارك
ابو جودي

ابو جودي

قام بنشر
قام بنشر (معدل)
في ٩‏/٩‏/٢٠١٩ at 08:40, محب العقيدة said:

السلا عليكم 

هناك وحدة نمطية واحدة  لتفقيط لاكثر من عملة وحسب عدد الخانات كالموجودة في فيديو قناة a soft

https://www.youtube.com/watch?v=RSIAgsq3ZDY

لكن للاسف رابط الملف لا يعمل.

احببت ان اطلع عليها  لو تكرم احد الاخوة الذي يملك الملف برفعه

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

اتفضل اعتقد طلبك هنا :biggrin::wink2: 

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

Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null)
myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue)
End Function

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

Private Function Delete(S As String, Index As Integer, Count As Integer) As String

Delete = Left(S, Index - 1) + _
         Mid(S, Index + Count, Len(S))

End Function

Private Function Insert(Source, S As String, Index As Integer) As String

Dim LPart As String

Dim RPart As String


LPart = Left(S, Index - 1)

RPart = Mid(S, Index, Len(S))

Insert = LPart & Source & RPart

End Function


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

Private Function AddAnd(S1 As String, S2 As String, S3 As String, _
And_ As String, Lang As Byte) As String

Dim InAnd_ As String

Dim 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


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

Private Function S2Double(Single_ As Variant, Sex As Byte) As String

Dim LLeter As Integer

Dim K    As Byte

Dim Sngl_1 As String

Dim 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


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

Private Function Fmale(Num As Byte, 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


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

Private 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

Private 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

Private 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


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

Private Function EHunds(Num As Byte, ESingle()) As String

EHunds = ESingle(Num) + " hundred"

End Function


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

Private 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


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

Private Function ReStr(InNum As String) As String

Dim K As Byte

Dim 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


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

Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _
Plural As String, Parts As Byte, Sex As Byte, 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 Parts_(0 To 11) As String

Dim Female(1 To 10) As Variant

Dim TempI        As Byte

Dim Sex2         As Byte

Dim K            As Byte

Dim Only_        As String

Dim OnlyPart     As String

Dim Part_        As String

Dim TempS        As String

Dim Sngl_1       As String

Dim Sngl_2       As String

Dim N1 As Byte, N2 As Byte, N3 As Byte

Dim N1_ As String, N2_ As String, N3_ As String


If Val(Num_) = 0 Then

If FracS = "" Then


     AOnly = RTrim("لا شيء " & Single_)

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_, Plural, Sngl_2, "", Lang)

         Else

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

         End If

         Else

         Only_ = AddAnd(Only_, Plural, "", "", 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)

         'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24

         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


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




Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _
Plural As String, Parts As Byte, 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 PartNum(0 To 5) As Long

Dim Result1(0 To 5) As String

Dim TempS        As String

Dim TempI        As Byte

Dim Sex2             As Byte

Dim OnlyPart         As String

Dim Part_        As String

Dim Only_        As String

Dim Leng             As Integer

Dim K            As Integer

Dim N1 As Byte, N2 As Byte, N3 As Byte

Dim N1_ As String, N2_ As String, N3_ As String


If Val(Num_) = 0 Then

If FracS = "" Then

     'EOnly = LTrim(Single_ & " zero")

     EOnly = RTrim("zero " & Single_)

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)

If Val(Num_) = 1 Then

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

Else

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

End If

EOnly = Only_

End If

End Function

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

Dim Num_ As String

Dim K    As Byte

Dim 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


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


Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _
Single_ As String, Plural As String, _
FSex As Byte, SFrac As String, PFrac As String, _
FracType As Byte) As Variant

Dim Leng As Byte

Dim Parts As Byte

Dim K    As Byte

Dim FracVal As Double

Dim Num_ As String

Dim FracS As String

Dim FracNum As String

Dim Only As String

Dim And_ 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") & "/" & CDbl(Format(FracNum, String(Dec, "0")))

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

     End Select

     Case 3

     FracS = CLng(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

                         FracS = EOnly(FracNum, "", SFrac, PFrac, 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_, Plural, Parts, Sex, Dec)

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

     End Select

Case 3, 4

     Select Case Lang

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

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

                     If FracType = 3 Then And_ = "و " Else And_ = "و"

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

     Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, 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 vArabic: B_Only = Only & " لا غير"

     'Case vEnglish: B_Only = Only & " only"

     Case vEnglish: B_Only = "Only " & Only

End Select

End If

End Function


'*******************************************************************************
'===========================asoft======================
Function ArbNum(ByVal InNum, _
Optional ByVal DecimalPlaces, _
Optional ByVal FractionType, _
Optional ByVal CurrencySingle, _
Optional ByVal CurrencyPlural, _
Optional ByVal CurrencySex, _
Optional ByVal FractionSingle, _
Optional ByVal FractionPlural, _
Optional ByVal FractionSex) As Variant


DecimalPlaces = Nz(DLookup("[cpro]", "tbl_curr", "[def] = true"), 2)
FractionType = 4
CurrencySingle = Nz(DLookup("[currNames]", "tbl_curr", "[def] = true"), "(عملة غير معرفة)")
CurrencyPlural = Nz(DLookup("[currNamep]", "tbl_curr", "[def] =true"), "(عملة غير معرفة)")
CurrencySex = 0
FractionSingle = Nz(DLookup("[ProName]", "tbl_curr", "[def] = true"), "(كسر غير معرف)")
FractionPlural = Nz(DLookup("[ProNamep]", "tbl_curr", "[def] = true"), "(كسر غير معرف)")
FractionSex = 0
ArbNum = "فقط" & " " & B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
CByte(myNz(FractionType)))



'-----------------------------------

If CStr(myNz(CurrencySingle)) = "درجة" And _
CStr(myNz(FractionSingle)) = "جزء" Then


Dim Grade As String

Dim FracS As String

Dim Pos As Integer
DecimalPlaces = Nz(DLookup("[cpro]", "tbl_curr", "[def] = true"), 2)
FractionType = 3
CurrencySingle = Nz(DLookup("[currNames]", "tbl_curr", "[def] = true"), "(عملة غير معرفة)")
CurrencyPlural = Nz(DLookup("[currNamep]", "tbl_curr", "[def] =true"), "(عملة غير معرفة)")
CurrencySex = 1
FractionSingle = Nz(DLookup("[ProName]", "tbl_curr", "[def] = true"), "(كسر غير معرف)")
FractionPlural = Nz(DLookup("[ProNamep]", "tbl_curr", "[def] = true"), "(كسر غير معرف)")
FractionSex = 0

'========================================xxx===============xxx==============
Grade = B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
CByte(myNz(FractionType)))



Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum)))

     Case 0:
     
     Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط ربع درجة لا غير", "ربع لا غير")

     Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط نصف درجة لا غير", "نصف لا غير")

     Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "فقط ثلاثة أرباع درجة لا غير", "ثلاثة أرباع لا غير")

     Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " لاغير"

End Select


If FracS <> "" Then

     Pos = InStr(1, Grade, " و ")

     If Pos > 0 Then

     Grade = Left(Grade, Pos + 1) & FracS

     Else

     Grade = FracS

     End If

End If


Pos = InStr(1, Grade, "درجة واحدة لاغير")

If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11)

Pos = InStr(1, Grade, "درجتان اثنتان لا غير")

If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14)


If CDbl(myNz(InNum)) = 0 Then Grade = "لا شيء"

ArbNum = "فقط" & " " & Grade

End If




End Function
'===========================asoft======================

Function ArbNum2Text(ByVal InNum, _
Optional ByVal DecimalPlaces = Null, _
Optional ByVal FractionType = 1, _
Optional ByVal CurrencySingle = "", _
Optional ByVal CurrencyPlural = "", _
Optional ByVal CurrencySex = 0, _
Optional ByVal FractionSingle = "", _
Optional ByVal FractionPlural = "", _
Optional ByVal FractionSex = 0) As Variant

Dim Negative As String


If IsNull(InNum) Then

ArbNum2Text = Null

Exit Function

Else

If InNum < 0 Then

     InNum = Abs(InNum)

     Negative = "سالب "

End If

End If


If IsNull(FractionType) Then FractionType = 1


If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then

If Not IsNull(DecimalPlaces) Then

     InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

End If

ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))

Exit Function

End If


If IsNull(DecimalPlaces) Then DecimalPlaces = 3

If InNum <> Fix(InNum) Then

If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then

     If FractionType > 2 Then FractionType = 1

End If

End If

ArbNum2Text = Negative & _
B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
CByte(myNz(FractionType)))


'-----------------------------------

If CStr(myNz(CurrencySingle)) = "درجة" And _
CStr(myNz(FractionSingle)) = "جزء" Then


Dim Grade As String

Dim FracS As String

Dim Pos As Integer

'========================================xxx===============xxx==============
Grade = Negative & _
 B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _
CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _
CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
CByte(myNz(FractionType)))


Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum)))

     Case 0:

     Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة لا غير", "ربع لا غير")

     Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة لا غير", "نصف لا غير")

     Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة لا غير", "ثلاثة أرباع لا غير")

     Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " لا غير"

End Select


If FracS <> "" Then

     Pos = InStr(1, Grade, " و ")

     If Pos > 0 Then

     Grade = Left(Grade, Pos + 1) & FracS

     Else

     Grade = FracS

     End If

End If


Pos = InStr(1, Grade, "درجة واحدة")

If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11)

Pos = InStr(1, Grade, "درجتان اثنتان")

If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14)


If CDbl(myNz(InNum)) = 0 Then Grade = "لا شيء"

ArbNum2Text = Grade

End If

'-- نهاية التعديل -------------------------------------------------------


End Function



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

Function EngNum2Text(ByVal InNum, _
Optional ByVal DecimalPlaces = Null, _
Optional ByVal FractionType = 1, _
Optional ByVal CurrencySingle = "", _
Optional ByVal CurrencyPlural = "", _
Optional ByVal FractionSingle = "", _
Optional ByVal FractionPlural = "") As Variant

Dim Negative As String


If IsNull(InNum) Then

EngNum2Text = Null

Exit Function

Else

If InNum < 0 Then

     InNum = Abs(InNum)

     Negative = "Negative only "

Else

     Negative = "Only "

End If

End If


If IsNull(FractionType) Then FractionType = 1

If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)"

If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)"


If myNz(CurrencySingle) = Empty Then

If Not IsNull(DecimalPlaces) Then

     InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces))

End If

EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType))

Exit Function

End If


If IsNull(DecimalPlaces) Then DecimalPlaces = 3

If InNum <> Fix(InNum) Then

If myNz(FractionSingle) = Empty Then

     If FractionType > 2 Then FractionType = 1

End If

End If


EngNum2Text = Negative & Mid( _
B_Only(CDbl(myNz(InNum)), vEnglish, 0, _
CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _
CStr(myNz(CurrencyPlural)), 0, _
CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _
CByte(myNz(FractionType))), 6)

End Function

 

كما انني اعتقد ان طلبك هنا كذلك فى هذا الموضوع ايضا :yes:

 

تم تعديل بواسطه ابا جودى
رابط هذا التعليق
شارك
حربي العنزي

حربي العنزي

قام بنشر
قام بنشر (معدل)

السلام عليكم اساتذتي الافاضل ورحمة وبركاته 

بعد أذن صاحب الموضوع الاستاذ الفاضل محب العقيدة 

استاذي الفاضل ابا جودي ربي يحفظك يارب هل بالامكان مثال بسيط على استخدام هذه الوحدة النمطية  - المثال يكون بصيغة اوفيس 2003 

مع وافر التحايا

تم تعديل بواسطه حربي العنزي
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept