تعديل التفقيط فى ملف عمل شهادات

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 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
  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 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_, Double_, 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 Female(1 To 10) As Variant
  Dim Parts_(0 To 11) As String
    
  If Val(Num_) = 0 Then
    AOnly = RTrim("فقط صفر " & Single_)
    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) = "كدرليونات"
 
  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(Double_, Fmale(2, CByte(sex), 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)
            Select Case N1_
              Case "ة", "ى", "ا"
              Case Else
                Only_ = Only_ + "ا"
            End Select
            N1_ = Mid(Only_, Len(Only_) - 2, 3)
            'هذا الشرط لحل مشكلة عدم التمييز بين "اءا" و "الا" 2002/02/15
            If N1_ = "اءا" And Single_ <> "ريال" Then
              Only_ = Left(Only_, Len(Only_) - 1)
            End If
         End If
      End Select
    Else
      Only_ = AddAnd(Only_, Single_, "", "", Lang)
    End If
    If Only_ <> "" Then Only_ = "فقط " + Only_
    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
    EOnly = LTrim(Single_ & " zero only")
    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) = "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(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 Only_ <> "" Then Only_ = Only_ + " only"
    EOnly = Only_
  End If
End Function

Function S_Only(InNum As Variant, Lang As Byte) As Variant
  Dim Num_ As String
  Dim K, dec 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
  
  S_Only = B_Only(InNum, Lang, 0, dec, "", "", "")
End Function

Function B_Only(InNum As Variant, Lang, sex, dec As Byte, Single_, Double_, Ploral_ As String) As Variant
  Dim Leng, Parts, K As Byte
  Dim FracVal  As Double
  Dim Num_     As String
  Dim FracS    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 = ""
  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 vArabic:  B_Only = AOnly(Num_, FracS, Single_, Double_, Ploral_, Parts, sex, dec)
    Case vEnglish: B_Only = EOnly(Num_, FracS, Single_ + "", Parts, dec)
  End Select
End Function

Sub Test()
  'اللغة 1=عربي  2=انجليزي
  '  الجنس  0=مذكر  1=مؤنث
  
  
  'الدالة الأولى
  'المدخلات الرقم واللغة
  MsgBox S_Only(1500, vArabic)
  '--------------------------------------------------
  'الدالة الثالثة
  '"المدخلات الرقم واللغة والجنس وطول الكسر و "مفرد،مثنى،جمع المعدود
  MsgBox B_Only(1500, vArabic, vMale, 2, "درجة", "درجتان", "درجات")
End Sub

هذا هو الكود المستخدم

بارك الله لكم

تم تعديل مايو 21, 2019 بواسطه ناصر سعيد

تسجيل الدخول

تعديل التفقيط فى ملف عمل شهادات

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

alsyedaly

سليم حاصبيا

alsyedaly

Ali Mohamed Ali

احمد بدره

alsyedaly

ناصر سعيد

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information