النتائج 1 إلى 8 من 8

الموضوع: اريد كود التفقيط فى الورد

عدد الردود: 7 ، عدد المشاهدات: 4656 ، رقم الموضوع: 880
  1. (رقم الرد: 4772) #1

    Post اريد كود التفقيط فى الورد


    اخوانى عندى فواتير يتم طباعتها من الورد و اريد كود لتفقيط الإجمالى



    وشكراااااااااااااااااااااااااااااااااااااااااااااا اا

  2. (رقم الرد: 5093) #2
    تاريخ التسجيل
    16-06-2008
    إصدار أوفيس
    2007
    المشاركات
    4,286
    مواضيعي / ردودي

    افتراضي

    كود:
     
    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
    On Error Resume Next
    Delete = Left(s, Index - 1) + _
    Mid(s, Index + Count, Len(s))
    End Function
    Function Insert(Source, s As String, Index As Integer) As String
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    EHunds = ESingle(NUM) + " hundred"
    End Function
    Function ReFormat(InNum As Double, dec As Byte) As Double
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    On Error Resume Next
    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
    If InNum <= 0 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
    هذه دالة تقوم بالتفقيط، تحيل إليها المبلغ المالي فترجع بالتفقيط:
    كود:
     
    B_Only(Me.Mony, 1, 0, 2, "ريال", "ريالين", "ريالات")
    وفقك الله
    التعديل الأخير تم أحمد الحربي ; 21-04-2009 الساعة 06:27

  3. (رقم الرد: 5136) #3

    افتراضي

    شكرا اخى العزيز على الرد
    ولكنى اطمع فى كرمك و اريد تطبيق عملى

  4. (رقم الرد: 5283) #4

    افتراضي

    أين يتم وضع هذا الكود
    برجاء الرد فأنا محتاج له جداً
    جزاك الله خيراً

  5. (رقم الرد: 5979) #5

    افتراضي

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

  6. (رقم الرد: 38070) #6

    افتراضي

    ممكن شرح للدالة ؟

  7. (رقم الرد: 42844) #7

    افتراضي

    وبطريقة اخرى وسهلة لتحويل عدد إلى حروف وان لا يكون العدد عشريا ولا يتعدى التحويل 100000 في M.Word بهذه الطريقة:
    نضغط على ctrl+f9 لادراج حقل.
    نكتب بين الحاضنتين : cardtext * \ .........= حيث النقط تمثل العدد المراد تحويله .
    نضغط على F9 ليتم التحويل والمؤشر داخل الحقل .
    نضغط SHIFT + F9 لتغيير العدد .
    يفضل ان يكون خيار اللغة على انجليزي او فرنسي عند بداية كتابة الكود .
    والسلام عليكم ورحمة الله وبركاته.

  8. (رقم الرد: 49234) #8

    افتراضي

    شيء جميل جدا جزاك الله كل خير

المواضيع المتشابهه

  1. تحويل النماذج في الورد الى صور
    sys في المنتدى وورد العام
    ردود: 8
    آخر مشاركة: 02-09-2009, 12:13
  2. إضافة كلمة سر إلي ملفات الورد بدون استخدام برامج
    ابـ محمد ـو في المنتدى وورد العام
    ردود: 10
    آخر مشاركة: 19-08-2009, 11:51

مواقع النشر (المفضلة)

مواقع النشر (المفضلة)

ضوابط المشاركة

  • لا تستطيع إضافة مواضيع جديدة
  • لا تستطيع الرد على المواضيع
  • لا تستطيع إرفاق ملفات
  • لا تستطيع تعديل مشاركاتك
  •  
unique hits
website security