كود او دالة للتفقيط بالريال السعودي

[usama_tnt@yahoo.com]

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

اولا : جزاكم الله خير على العلم الذي تشاركونه مع الجميع فأنه يكتب في ميزان حسناتكم

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

تعبت ادور وكل مأنزل ملف مايظبط 

ومرفق لكم ملف اكسيل الذي اريد استخدم معه التفقيط (مع العلم هناك ملفات اكسيل اخرى بعمل لها تفقيط )

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

انا اسف على الاطالة

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

اخوكم / اسامة الطناني

طلب صرف.xlsx

[طارق نادر]

تفضل اخي الكريم.. من خبرات اخواني الاعضاء لعله يفي بالغرض..

 

طلب صرف (1).xlsm

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

[usama_tnt@yahoo.com]

بارك الله فيك اخي طارق

بس المشكلة ظهر عندي الحروف على هيئة رموز وعلامات وارفقت لحضرتك صورة pdf  من طلب الصرف الخاص بحضرتك اللي ارسته بعد مافتحته ظهرت الحروف رموز

ممكن تعرفني ايه الحل؟؟؟؟!!!

طلب صرف.pdf

[طارق نادر]

اخي الكريم..

تأكد من اللغة في control panal ان تكون اللغة العربية (السعودية) لان الملف شغال عندي تمام...

[usama_tnt@yahoo.com]

بارك الله فيك اخي طارق

المشكلة لازالت قائمة وقمت بتغير اللغة الي السعودية ونفس الحالة لم تتغير بقيت رموز وغير اللغة بالاوفيس ايضا ولم يتغير شيء

لو سمحت لو ممكن السورس او المعادلة نفسها و طريقة تصطيبها وانا اسطبها بنفسي ياريت

والف الف الف شكر لك

[طارق نادر]

اخي الكريم..

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

=ArbNum2Text(B13) &  " ريال  فقط  "
في الخلية

'-- 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, 4)
    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

ضعهه في موديل الملف

 

[Ali Mohamed Ali]

اخى الكريم اسامة عليك بمشاهدة هذا الرابط لمعرفة كيفية ضبط اللغة عندك

https://www.officena.net/ib/topic/87988-اللغه-العربيه-في-الاكسيل-2010-لا-تظهر-بشكل-صحيح/?tab=comments#comment-556696

[usama_tnt@yahoo.com]

اخي علي اخي طارق بارك الله فيكم

الحمد لله تم عمل التعديل حسب شرح استاذ علي

والملف اوك

باقي اخي طارق معلش على الاطالة الهللات غير موجودة بالتفقيط

يعني لو في هللات 

مثلا 3500.35

يكتبها :ثلاثة الاف وخمسمائة و0.35 ريال لاغير

انا اسف على الاطالة بس لو امكن تضيف الهللات

ومعلش كمان مرة بالنسبة للكود اللي حضرتك بعته لي وقولتلي انسخه والصقه بالموديل

اين المسار معلش

بمعنى مسار الملف اللي هيتلصق فيه 

وهل الكود ده فيه الهللات

ارفقت لحضرتك الملف اللي لايظهر هللات

 

طلب صرف (1).xlsm

[طارق نادر]

تفضل اخي الكريم...حسب المطلوب

 

طلب صرف (1).xlsm

[أ / محمد صالح]

جزاكم الله كل خير جميعا. وأحب أن أبشركم بأني في طريقي للانتهاء من برمجة أقصر واسرع كود للتفقيط (54 سطر برمجي) متعدد اللغات ويمكن تخصيصه لجميع العملات. ولكن نظرا لاهتمامي بلغة الويب قمت بعمله أولا في هذه الصفحة أونلاين
https://www.mr-mas.com/p/tafqeet.html

وجاري تحويله ليعمل على فيجوال بيسك للتطبيقات vba
تابعونا