تعديل على كود تفقيط رجاءا

[طارق_نادر]

لدي كود تفقيط حصلت عليه من المنتدى الكريم ولكن اريد التعديل عليه في جزئية بسيطة وهي رقم (200) اريد ان يكتبها الكود مائتان ولكن الكود يكتبها مائتا اظن السبب ان هناك كلمة تليها وهي درجة ولكني حذفتها لاسباب خاصة بمشروعي ارجو المساعدة رجاء

'-- Abo Hadi, 28/07/2003 --'
'-- Last update on 28/07/2006
' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت
'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب
' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط
'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح
Option Explicit
Public Const vArabic As Byte = 1
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 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 7) As Long
  Dim Result1(0 To 8) As String
  Dim Parts_(0 To 13) 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) = "ترليوناتٍ"
  Parts_(12) = "كدرليوناتٍ"
  Parts_(13) = "كوينتليوناتٍ"
  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 <> "" And InStr(2, Plural, Sngl_2) > 0 Then
    Sngl_2 = ""
  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) + 7)
            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
    '{------------------------------------------}
    For K = 0 To Parts - 1
      Only_ = AddAnd(Only_, Result1(K), "", And_, Lang)
    Next K
    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 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_ = CStr(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
  If Dec > 6 Then Dec = 6
  Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0"))
  If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = ""
  If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1)
  FracVal = Val(FracS)
  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")))
    End Select
      Case 3
        Select Case Lang
          Case vArabic:  FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac)
                  End Select
      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)
                  End Select
    End Select
  End If
  Leng = Len(Num_)
  Parts = Fix((Leng + 2) / 3)
  If Parts > 7 Then
    B_Only = InNum
    Exit Function
  End If
  For K = 1 To (Parts * 3) - Leng
    Num_ = Insert("0", Num_, 1)
  Next K
  Select Case FracType
    Case 1, 2
      Select Case Lang
        Case vArabic:  Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, 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))
       
      End Select
  End Select
  If Only <> "" Then
    Select Case Lang
      Case vArabic:  B_Only = Only
    End Select
  End If
End Function
'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث
' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات
Function ArbNum2Text(ByVal InNum, _
            Optional ByVal DecimalPlaces = 2, _
            Optional ByVal FractionType = 4, _
            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 = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))
    End If
    ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))
    Exit Function
  End If
  If IsNull(DecimalPlaces) Then DecimalPlaces = 2
  InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))
 'If InNum <> Fix(InNum) Then
  If Val(Right(InNum, DecimalPlaces)) > 0 Then
    If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then
      If FractionType > 2 Then FractionType = 1
    End If
  End If
  ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح
   Dim m
   m = " فقطُ لا غيرَ"
  ArbNum2Text = Negative & _
                B_Only(CDec(myNz(InNum, 0)), 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))) & m
End Function

[طارق_نادر]

للرفع

[ياسر خليل أبو البراء]

ارفق ملف به الدالة أخي الحبيب..

وارفق شكل الدالة المستخدمة ....في ورقة العمل

أو يمكنك البحث عن دالة تفقيط أخرى فما أكثرها في المنتدى إذا بحثت

[طارق_نادر]

هذه الداله اخي الكريم  

=ArbNum2Text(G6) & " فقط  "

[بن علية حاجي]

السلام عليكم ورحمة الله

 

أخي الكريم n_tareq يمكنك تعديل ذلك في كود الدالة Hunds التالي :

 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 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, 4)
    Case 3 To 9: Hunds = Female(num) + Hund
   End Select
End Function

والتعديل كان في الجزئية (Mid(Female(2), 4, 3 في أمر Case 2 من السطر الخامس في الكود بالجزئية (Mid(Female(2), 4, 4 وتم تعديل الرقم 3 في الجزئية بالرقم 4...

 

أرجو أن يكون هذا المطلوب...

 

أخوك بن علية

[طارق_نادر]

كل الشكر والتقدير ارفع لك القبعة احتراما لخبرتك الكبيرة تم المطلوب بكل حرفية  اخي الفاضل والعلامة بن علية 

[أبو عبد الرحمن سعيد]

اخى العزيز المتألق دائما الاستاذ // بن عليه حاجى

طابت أوقاتكم بكل خير وجزاكم الله خيرا

واسمح لى بهذا التعديل البسيط  حتى تكون عملية

التفقيط سليمة .... تم حذف " كلمة فقط من الكود لتصبح لاغير"

والشكر لاخى الاستاذ الفاضل // طارق الذى جمعنا بتلك المشاركة الطيبة

 دمتم فى أمان الله ........ تقبلوا وافر تقديرى واحترامى

' تم إضافة كلمة لا غير في آخر التفقيط بواسطة محمد صالح
   Dim m
   m = " لا غيرَ"
  ArbNum2Text = Negative & _
                B_Only(CDec(myNz(InNum, 0)), 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))) & m
End Function

 

تم تعديل يناير 25, 2015 بواسطه سعيد بيرم

[شيتوس]

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

بارك الله فيكم على المعلومات القيمه

دالة التفقيط هذه تعمل معى ولكن حين أحفظ الصفحه ينتهى كل شئ فلم تعد الداله موجوده فما العلاج

[GasserReda]

قم بحفظ المصنف بالامتداد Macro-Enabled لتتمكن من الاحتفاظ بالدالة حيث أن الدالة يطلق عليها User Defined Function أو دالة معرفة

قم بوضع الدالة في محرر الأكواد ثم حفظ باسم واختار Macro-Enabled ليتم حفظ المنصف بالامتداد xlsm

وشكرا

[شيتوس]

أنا شاكر لرد حضرتك بس انا بحفظ بmacro enable workbook وفى النهايه الكود بيتحفظ كاسم فى المديول بس الداله مش فعاله خالص فمشكورا لو فيه شئ معين أنا عملته خطأ