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

السيد عبد الفتاح · نوفمبر 29, 2010

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

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

**ابوخليل** · نوفمبر 30, 2010

هذا مثال يحتوي على كود تفقيط

لعلك تجد فيه فائدة

خمسة وخمسون.rar

تم تعديل نوفمبر 30, 2010 بواسطه أبو الأنس

السيد عبد الفتاح · ديسمبر 1, 2010

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

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

sft · ديسمبر 1, 2010

وانا تمنيت ان أعرف الطريقة .... ؟؟؟؟؟؟؟

عبـد الله · ديسمبر 2, 2010

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

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

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

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

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

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

deyamag · ديسمبر 5, 2010

الماكرو Disabled

عبـد الله · ديسمبر 6, 2010

عدل امان الماكرو الى منخفض

hussien030 · ديسمبر 6, 2010

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

**ابوخليل** · ديسمبر 6, 2010

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

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

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

محمود العامر · يناير 4, 2011

شكرا اخي على الكود

محمود العامر · يناير 4, 2011

من اين يتم تحميل رابط هذا الكود

**تومي محمد** · مارس 16, 2011

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

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

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

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

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

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

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

تم تعديل نوفمبر 3, 2012 بواسطه تومي محمد

المقداد · يناير 8, 2015

اشكركم ولكن كيف يتم تعديل امان الماكرو في 2007 حيث يتم ارسال رسالة نختار منها ( تمكين) ولكن يظل بدون ايقونه

**أبو محمد عباس** · يناير 10, 2015

السلام عليكم

اخي المقداد لاحظ الشرح على الرابط التالي للاستاذ احمد النجار جزاه الله خيرا

دمتم في رعاية الله وحفظه

http://www.officena.net/ib/index.php?showtopic=51032#entry314613

hat · فبراير 8, 2015

السلام عليكم

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

افتح ماكرو جديد وسمه ( 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

hat · فبراير 9, 2015

اسم الماكرو يكون num2txt بدلا من word لذا لزم التنويه

تم تعديل فبراير 9, 2015 بواسطه hat

hayderflah · فبراير 24, 2021

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

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

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

hat · فبراير 26, 2021

في ٢٤‏/٢‏/٢٠٢١ at 21:17, hayderflah said:

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

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

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

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

hayderflah · فبراير 26, 2021

في ٨‏/٢‏/٢٠١٥ at 19:21, hat said:

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

1.docx

هاشم طه · مارس 2, 2021

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

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

مرفق ملف وورد 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

hayderflah · مارس 2, 2021

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

وفقكم الله لكل خير

hat · مارس 2, 2021

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

1.docx 21.25 kB · 2 downloads

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

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

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

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

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

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

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

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

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

hayderflah · مارس 2, 2021

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

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

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

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

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

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

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

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

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

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

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

تسجيل الدخول

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

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

السيد عبد الفتاح

ابوخليل

السيد عبد الفتاح

sft

عبـد الله

deyamag

عبـد الله

hussien030

ابوخليل

محمود العامر

محمود العامر

تومي محمد

المقداد

أبو محمد عباس

hat

hat

hayderflah

hat

hayderflah

هاشم طه

hayderflah

hat

hayderflah

Join the conversation

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

تصفح الموقع

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

Support

Important Information