اذهب الي المحتوي
أوفيسنا

كود تفقيط وورد


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

السادة / خبراء وأعضاء المنتدى ... المحترمين

أرجو المساعدة في ايجاد كود تفقيط يعمل على الوورد لعملة الدينار الكويتي علما بان كسر الدينار هو 1000 فلس ولكم جزيل الشكر

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

أخي العزيز / ابو خليل

جزاك الله خيرا على الاستجابة ومحاولة المساعدة ولكن كيف يتم تطبيق تفقيط الارقام بالوورد فانا على علم بالتفقيط بالاكسيل اما الوورد فلست على دراية به ... ارجو التوضيح

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

يا اخواني المسألة واضحة

اكتب الرقم الذي تريد ثم انقر الايقونة الخاصة ليتحول الرقم الى حروف

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

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

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

السؤال : الا يمكن تحويل هذه الايقونة الى زر من ازرار لوحة المفاتيح ، لتسهيل التعامل ؟

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

هذه فائدة من اخينا حامل المسك

برنامج تنفيذي لادراج التفقيط داخل الوورد

http://www.officena.net/ib/index.php?showtopic=24818&view=findpost&p=116557&hl=%C7%E1%CA%DD%DE%ED%D8&fromsearch=1

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

  • 5 weeks later...
  • 2 months later...

تحويل عدد إلى حروف وان لا يكون العدد عشريا ولا يتعدى التحويل 999999 في M.Word بهذه الطريقة:

نضغط على ctrl+f9 لادراج حقل.

نكتب بين الحاضنتين : cardtext * \ .........= حيث النقط تمثل العدد المراد تحويله .

نضغط على Alt+F9 ليتم التحويل والمؤشر داخل الحقل .

نضغط SHIFT + F9 لتغيير العدد .

يفضل ان يكون خيار اللغة على انجليزي او فرنسي عند بداية كتابة الكود .

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

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

  • 3 years later...
  • 5 weeks later...

السلام عليكم

 

الاخوه الكرام سبق وان وضعنا كود تفقيط لوورد واجد مازرال هناك بعض الاخوه يسألون لذلك سوف ابسط المسالة قدر الامكان

 

افتح ماكرو جديد وسمه (   word   ) مثلا 

انسخ الكود التالي داخل الماكرو واحفظه

ويمكن ان تخصص له زر في شريط الاوامر

وبعد الانتهاء اكتب الرقم ثم اضغط تنفيذ ماكرو (      word  )   او الاسم الذي اخترته    واستمتع بالتفقيط . 

 

وانا استخدم وورد  2013 لذلك سارفق ملف بصيغة وورد 97 و 2003 واذا لم يعمل على اصدارات وورد المختلفة ارجو تحويله للاصدار المناسب

 

 

فقط إثنا عشر ألفاً و خمسمائة و أربعة و أربعون ريالاً لا غير.rar

 

 

Sub num2txt()
'
' num2txt Macro
'
'
Dim CursorMovement As Long
Sub num2text()
'
    On Error Resume Next
    Selection.HomeKey Unit:=wdLine
    Selection.EndKey Unit:=wdLine, Extend:=wdExtend
        Selection = word(Selection)
  Selection.EndKey Unit:=wdLine
Selection.MoveDown
Selection.TypeBackspace
   Selection.TypeParagraph
 MsgBox "ادخل ارقام جدديدة واضغط للتحويل لارقام ", vbExclamation, "رسالة هاشم "
End Sub

Public Function word(x)
On Error Resume Next

ra = " ريالاً "
ha = " هللة "
n = Int(x)
b = Val(Right(Format(x, "000000000000000.00"), 2))
r = aword(n)
b1 = aword(b)

 If n > 999999999999999# Then
 MsgBox "هذا الرقم كبير جدأ .. لطفاً ادخل رقماً يقل عن 999.99 ترليون ", vbInformation, "رسالة هاشم "
Selection.Copy
Selection.Paste

Exit Function
End If
If b >= 3 And b <= 10 Then ha = " هللات "
If Right(n, 1) >= 3 And Right(n, 1) <= 10 Then

If Right(n, 2) < 10 Then ra = " ريالات "
End If
If b = 2 Then b1 = " هللتان ": ha = ""
If b = 1 Then b1 = " هللة واحدة ": ha = ""

If n = 1 Then r = "ريال واحد ": ra = ""

If r <> "" And b >= 0 Then Result = " فقط " & r & ra & " و" & b1 & ha & " لا غير ."
If r = "" And b <> 0 Then Result = " فقط " & b1 & ha & "  لا غير "

If r = "" And b = 0 Then Result = ""
If r <> "" And b = 0 Then Result = " فقط " & r & ra & " لا غير . "

word = Result

End Function

Private Function aword(x)
n = Int(x)
c = Format(n, "000000000000000")

c1 = Val(Mid(c, 15, 1))

Select Case c1
Case Is = 1: letr1 = "واحد"
Case Is = 2: letr1 = "إثنان"
Case Is = 3: letr1 = "ثلاثة"
Case Is = 4: letr1 = "أربعة"
Case Is = 5: letr1 = "خمسة"
Case Is = 6: letr1 = "ستة"
Case Is = 7: letr1 = "سبعة"
Case Is = 8: letr1 = "ثمانية"
Case Is = 9: letr1 = "تسعة"
End Select

c2 = Val(Mid(c, 14, 1))
Select Case c2
Case Is = 1: letr2 = "عشر"
Case Is = 2: letr2 = "عشرون"
Case Is = 3: letr2 = "ثلاثون"
Case Is = 4: letr2 = "أربعون"
Case Is = 5: letr2 = "خمسون"
Case Is = 6: letr2 = "ستون"
Case Is = 7: letr2 = "سبعون"
Case Is = 8: letr2 = "ثمانون"
Case Is = 9: letr2 = "تسعون"
End Select

If letr1 <> "" And c2 > 1 Then letr2 = letr1 + " و " + letr2
If letr2 = "" Then letr2 = letr1

If c1 = 0 And c2 = 1 Then letr2 = letr2 + "ة"

If c1 = 1 And c2 = 1 Then letr2 = "إحدى عشر"
If c1 = 2 And c2 = 1 Then letr2 = "إثنا عشر"

'If c1 = 2 And c2 = 0 Then letr2 = "ريالان"

If c1 > 2 And c2 = 1 Then letr2 = letr1 + "  " + letr2

c3 = Val(Mid(c, 13, 1))

Select Case c3
Case Is = 1: letr3 = "مائة"
Case Is = 2: letr3 = "مئتان"

Case Is = 8: letr3 = Left(aword(c3), Len(aword(c3)) - 2) + "مائة"
Case Is > 2: letr3 = Left(aword(c3), Len(aword(c3)) - 1) + "مائة"

End Select

If letr3 <> "" And letr2 <> "" Then letr3 = letr3 + " و " + letr2
If letr3 = "" Then letr3 = letr2

'=====
c4 = Val(Mid(c, 10, 3))

Select Case c4
Case Is = 1: letr4 = " ألف"
Case Is = 2: letr4 = " ألفان"
Case 3 To 10: letr4 = aword(c4) + " آلاف"
Case Is > 10: letr4 = aword(c4) + " ألفاً"

End Select

If letr4 <> "" And letr3 <> "" Then letr4 = letr4 + " و " + letr3

If letr4 = "" Then letr4 = letr3
'=====

c5 = Val(Mid(c, 7, 3))

Select Case c5
Case Is = 1: letr5 = " مليون"
Case Is = 2: letr5 = " مليونان"
Case 3 To 10: letr5 = aword(c5) + " ملايين"
Case Is > 10: letr5 = aword(c5) + " مليوناً"

End Select

If letr5 <> "" And letr4 <> "" Then letr5 = letr5 + " و " + letr4
If letr5 = "" Then letr5 = letr4

'==

c6 = Val(Mid(c, 4, 3))

Select Case c6
Case Is = 1: letr6 = " مليار"
Case Is = 2: letr6 = " ملياران"
Case 3 To 10: letr6 = aword(c6) + " مليارات"
Case Is > 10: letr6 = aword(c6) + " ملياراً"

End Select

If letr6 <> "" And letr5 <> "" Then letr6 = letr6 + " و " + letr5
If letr6 = "" Then letr6 = letr5

'=====

c7 = Val(Mid(c, 1, 3))

Select Case c7
Case Is = 1: letr7 = " ترليون"
Case Is = 2: letr7 = " ترليونان"
Case 3 To 10: letr7 = aword(c7) + " ترليونات"
Case Is > 10: letr7 = aword(c7) + " ترليوناً "

End Select

If letr7 <> "" And letr6 <> "" Then letr7 = letr7 + " و " + letr6
If letr7 = "" Then letr7 = letr6

aword = letr7

End Function

 

 

 

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

  • 6 years later...
في ٢٤‏/٢‏/٢٠٢١ at 21:17, hayderflah said:

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

لماذا لا يعمل المايكرو على خلايا الجدول 

ممكن المساعدة 

يعمل على وورد وهناك ماكرو للجداول باكسيل ولكن لو ترفق الجدول الذي تعمل عليه بدون بيانات حتى يتسنى لي مساعدتك.

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

الأخ حيدر فلاح

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

 

مرفق ملف وورد 2019 ارجو ان يعمل معك وممكن به ماكرو رقم 1 

او انسخ الكود التالي وضعه في موديل واضغط على ماكرو وسيعمل في الجدول باذن الله

وبالطبع عمل التفقيط في كل خلية في جدول وورد غير مجدي فالافضل عمل التفقيط في نهاية الفواتير والاقضل عملها باكسيل 

 

Private Const MyBegTx As String = " فقط "
Private Const MyEndTx As String = "  لا غير"
'                -----------------------
Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"


Private Const wow As String * 2 = " و"

 
Function CurrText(Num As String, _
Optional Sex As Boolean = False, _
Optional NCurr_Si As String = "دينار", _
Optional NCurr_Pl As String = "دنانير", _
Optional dSex As Boolean = False, _
Optional NCurrDec_Si As String = "فلس", _
Optional NCurrDec_Pl As String = "فلوس", _
Optional Decimal_Count As Byte = 3) _
As String
'======================================
Dim Spp, zt
Dim i%, ii%, pr%
Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$
'======================================
If Not IsNumeric(Num) Then GoTo kh_Exit
If Num = 0 Then
MsgBox "لطفاً أدخل رقم...ليتم التحويل . ", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "رسالة هاشم "
 Selection.Text = ""
 GoTo kh_Exit
End If
'======================================
Spp = Split("/" & MyTNum, "/")
ii = UBound(Spp)
If Num < 0 Then Num = Abs(Num)
'======================================
If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit
'======================================
nCurr = NCurr_Si & "-" & IIf(NCurr_Pl = "", NCurr_Si, IIf(NCurr_Si = "", "", NCurr_Pl))
'======================================
Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000")
For i = 0 To ii
    MyMid = Mid(Txt1, (i * 3) + 1, 3)
    If MyMid Then
        zt = Mid(Txt1, (i * 3) + 4, Len(Txt1))
        zt = IIf(ii - i, Int(zt), 1)
        Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr)
        pr = 1 + IIf(ii - i, 1, CInt(Sex))
        Txt = Txt & IIf(Len(Txt), wow, "") & kh_nText(MyMid, Txt2, pr, zt, CBool(NCurr_Si <> ""))
    End If
    If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " " & NCurr_Si, IIf(Decimal_Count = 0, "صفر", ""))
Next
'======================================
Txt = MyBegTx & Txt & kh_dText(Num, NCurr_Si, Trim(NCurrDec_Si), Decimal_Count, Trim(NCurrDec_Pl), dSex) & MyEndTx
'======================================
kh_Exit:
CurrText = Trim(Txt)
End Function
'    معالجة العدد من 1 الى 999   لكل فئات الرقم
Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal Z As Boolean, ByVal tCu As Boolean) As String
Dim Sp
Dim Num1%, Num2%, Num3%
Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$
'======================================
Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",")
'======================================
If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة"
oM = Trim(Split(oMm, "-")(0))
'======================================
Num1 = Left(iNum, 1)
Num2 = Right(iNum, 2)
Select Case Num1
    Case 1:      nT0 = "مائة"
    Case 2:      nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن"))
    Case 3 To 9: nT0 = Sp(Num1) & "مائة"
End Select
'=========================================
Num1 = Right(iNum, 2)
Select Case Num1
    Case 1, 2:     If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM
    Case 11 To 99: If oM <> "" Then If ibs Then If Z Then oM = oM & "اً"
End Select
'-----------------------------------------
Select Case Num1
    Case 1
        nT = IIf(oM = "", Sp(0) & S1, oM)
        oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "")
    Case 2
        nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(Z = 0 And ibs = 2 And tCu, "ا", "ان"))
        oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "")
    Case 3 To 10
        oM = Trim(Split(oMm, "-")(1))
        nT = Sp(Num1) & S
    Case 11, 12
        nT = Sp(Num1) & Sp(10) & S1
    Case 13 To 19
        nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1
    Case 20 To 99
        Num2 = Right(Num1, 1)
        Num3 = Left(Num1, 1)
        If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون"
        nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & wow & nT1
        If Num2 = 0 Then nT2 = nT1
        nT = nT2
End Select
'======================================
S = IIf(nT = "" Or iNum < 100, "", wow)
nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية")
kh_nText = Trim(nT0 & S & nT & " " & oM)
'======================================
End Function
'            معالجة الكسر
Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte, ByVal Ndec_pl As String, ByVal dsx As Boolean) As String
Dim Td$, dwow$, Td1$
On Error GoTo 1
If co = 0 Then GoTo 1
If NCur = "" Then Ndec = ""
Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0"))
If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1
If Int(dNum) Then dwow = wow
If Len(Ndec) Then
    Ndec = " " & Ndec
    Td1 = Td * CVar("1" & String(co, "0"))
    If Len(Ndec_pl) And co < 4 Then Td1 = dwow & kh_nText(Format(Td1, "000"), Ndec & "-" & Ndec_pl, 1 + CInt(dsx), 1, 0): GoTo 1
Else
    Ndec = " " & NCur: Td1 = Td
End If
Td1 = dwow & " " & Chr(40) & Td1 & Chr(41) & Ndec
1: kh_dText = Td1
End Function

Sub Macro1()
    
    lCursorMovement = Options.CursorMovement
   
    If Options.CursorMovement = wdCursorMovementVisual Then Options.CursorMovement = wdCursorMovementLogical
    
    
    lRange = Selection.MoveWhile(cset:="0123456789.,،", Count:=wdBackward)
    
    lParaAlignment = Selection.ParagraphFormat.Alignment
    
    Selection.ParagraphFormat.ReadingOrder = RtlPara
    
    Selection.ParagraphFormat.Alignment = lParaAlignment
    
 If lRange <> 0 Then
        Selection.MoveRight Unit:=wdCharacter, Count:=-lRange, Extend:=wdExtend
    
    
              
                Selection.TypeText CurrText(Selection)
   


  End If
    
     

    
End Sub

 

n2w.docm

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

في ٢٦‏/٢‏/٢٠٢١ at 18:15, hayderflah said:

الاخ حيدر فلاح

 

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

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

واحب ان اوضح لك عدة نقاط 

1 يجب ان تعمل على الاكسيل في عمل الجداول.

2 وضع التفقيط داخل الجدول غير عملي ولكن يكون في نهاية الجدول لاظهار الاجمالي.

3 عند وضع فاصلة العملة لا تستعمل فاصلة الكتابة العادية ولكن استعمل النقطة التي اعلى حرف الزاي في لوحة المفاتيح.

4 وضعت لك الملف كقالب حتى تستخدمه عدة مرات وتحفظ عملك بشكل منفصل ان اردت ذلك.

 

تحياتي وتقديري لشخصك الكريم.

 

 

 

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

42 دقائق مضت, hat said:

الاخ حيدر فلاح

 

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

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

واحب ان اوضح لك عدة نقاط 

1 يجب ان تعمل على الاكسيل في عمل الجداول.

2 وضع التفقيط داخل الجدول غير عملي ولكن يكون في نهاية الجدول لاظهار الاجمالي.

3 عند وضع فاصلة العملة لا تستعمل فاصلة الكتابة العادية ولكن استعمل النقطة التي اعلى حرف الزاي في لوحة المفاتيح.

4 وضعت لك الملف كقالب حتى تستخدمه عدة مرات وتحفظ عملك بشكل منفصل ان اردت ذلك.

 

تحياتي وتقديري لشخصك الكريم.

 

 

 

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

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

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