تفقيط سلس وسريع في وورد

[scorpion4ever]

أخي الكريم المسألة بسيطة جداً فقط اتبع الخطوات ولا تهمل منها شيء

1-حمل الملفات المرفقة بالمقال والموضوعة بملف مضغوط وبعد فك الضغط ينتج لك الملفين التاليين Module1 و NewMacros

2-افتح وورد ومن قائمة أدوات اختر : ماكرو > محرر Visual Basic

3-من قائمة File اختر Import file ثم اختر الملفات التي قمت بتحميلها من المرفق

4-اغلق صفحة Visual Basic وارجع لصفحة وورد

5-من قائمة عرض اختر أشرطة أدوات > تخصيص ، ومن التبويب الأوامر وتحت قائمة فئات اختر وحدات ماكرو لتظهر فى القائمة المقابلة أمر Normal.NewMacros.تفقيط واضغط علية بالماوس مع السحب إلى شريط القوائم أو أي مجموعة من الأزرار

6-يمكنك تعديل الاسم والخواص بالضغط بالزر الأيمن على الأمر الجديد وذلك قبل غلق مربع حوار تخصيص

7-اكتب أي رقم مرغوب في وورد ثم حدده وهذه النقطة مهمة " التحديد" ثم اكبس الزر أز الأمر الذي أنتجته فيظهر التفقيط فوراً

8- لتغيير الليرة السورية والقرش افتح وورد ومن قائمة أدوات اختر : ماكرو > محرر Visual Basic ثم اتجه لمجموعة النورمال Normal > ومنها Modules ثم افتح المسمى New Macros فتجد نوع العملة قم بتغييرها من هنا

نجاح العملية معك يعتبر نجاح لي ولك على السواء

scorpion4ever

المرفق

Tafqeet.rar

[ابوخليل]

معلومة جميلة وشرح وافي

جزاك الله خيرا

ويشرفنا دعوتك لمشاركتنا هنا

http://www.officena.net/ib/index.php?showtopic=41520

[تومي محمد]

شكرا على المجهود الجبار ...

لكن جربته فلا يدعم اللعة العربية فتظهر على شكل علامات استفهام

فما السبب

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

[aliadel]

موضوع شيق جدا بس ياريت ممكن توضحة على ورد 2007

[hat]

كود تفقيط سهل جداً

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

ثم اكتب اي رقم وشغل الماكرو واعلمني بالنتيجة وشكرا لكم سلفا

اخوكم هاشم احمد طه

[/left]


[left]

Public Function word(x)

On Error Resume Next[/left]


[left]

ra = " ريالاً "

ha = " هللة "

n = Int(x)

b = Val(Right(Format(x, "000000000000000.00"), 2))

r = aword(n)

b1 = aword(b)

If Len(n) > 15 Then

			   MsgBox " عفواً.... هذه الأداة لا تدعم أكثر من 15 خانة عددية ولأقرب جزء من مائة    " & Chr$(13) & Chr$(13) & "   وأعتقد بأن هذه الرقم يكفي لإنجاز أي عملية حسابية .", vbOKOnly + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تحويل الارقام الى نص"

			    Exit Function

		   End If[/left]


[left]If n < 0 Then[/left]


[left]q = " يتبقى لكم "

Else

q = " فقط "

End If[/left]


[left]

If b >= 3 And b <= 10 Then ha = " هللات "

If Right(n, 1) >= 3 And Right(n, 1) <= 10 Then[/left]


[left]If Right(n, 2) < 10 Then ra = " ريالات "

End If

If b = 2 Then b1 = " هللتان ": ha = ""

If b = 1 Then b1 = " هللة واحدة ": ha = ""[/left]


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


[left]If r <> "" And b >= 0 Then Result = q & r & ra & " و" & b1 & ha & " لا غير ."

If r = "" And b <> 0 Then Result = q & b1 & ha & "  لا غير "[/left]


[left]If r = "" And b = 0 Then Result = ""

If r <> "" And b = 0 Then Result = q & r & ra & " لا غير . "[/left]


[left]word = Result[/left]


[left]End Function[/left]


[left]Private Function aword(x)

n = Int(x)

If n < 0 Then n = n * -1 - 1[/left]


[left]c = Format(n, "000000000000000")

'If Len(c) > 15 Then

'			    MsgBox " عفواً.... هذه الأداة لا تدعم أكثر من 15 خانة عددية ولأقرب جزء من مائة    " & Chr$(13) & "   وأعتقد بأن هذه الرقم يكفي لإنجاز أي عملية حسابية .", vbOKOnly + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "تحويل الارقام الى نص"

'			    Exit Function

'		    End If

c1 = Val(Mid(c, 15, 1))[/left]


[left]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[/left]


[left]

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[/left]


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

If letr2 = "" Then letr2 = letr1[/left]


[left]If c1 = 0 And c2 = 1 Then letr2 = letr2 + "ة"[/left]


[left]If c1 = 1 And c2 = 1 Then letr2 = "إحدى عشر"

If c1 = 2 And c2 = 1 Then letr2 = "إثنا عشر"[/left]


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


[left]If c1 > 2 And c2 = 1 Then letr2 = letr1 + "  " + letr2[/left]


[left]

c3 = Val(Mid(c, 13, 1))[/left]


[left]Select Case c3

Case Is = 1: letr3 = "مائة"

Case Is = 2: letr3 = "مئتان"[/left]


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

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


[left]End Select[/left]


[left]If letr3 <> "" And letr2 <> "" Then letr3 = letr3 + " و " + letr2

If letr3 = "" Then letr3 = letr2[/left]


[left]'=====

c4 = Val(Mid(c, 10, 3))[/left]


[left]Select Case c4

Case Is = 1: letr4 = " ألف"

Case Is = 2: letr4 = " ألفان"

Case 3 To 10: letr4 = aword(c4) + " آلاف"

Case Is > 10: letr4 = aword(c4) + " ألفاً"[/left]


[left]End Select[/left]


[left]If letr4 <> "" And letr3 <> "" Then letr4 = letr4 + " و " + letr3[/left]


[left]If letr4 = "" Then letr4 = letr3

'=====[/left]


[left]

c5 = Val(Mid(c, 7, 3))[/left]


[left]Select Case c5

Case Is = 1: letr5 = " مليون"

Case Is = 2: letr5 = " مليونان"

Case 3 To 10: letr5 = aword(c5) + " ملايين"

Case Is > 10: letr5 = aword(c5) + " مليوناً"[/left]


[left]End Select[/left]


[left]If letr5 <> "" And letr4 <> "" Then letr5 = letr5 + " و " + letr4

If letr5 = "" Then letr5 = letr4[/left]


[left]'==[/left]


[left]c6 = Val(Mid(c, 4, 3))[/left]


[left]Select Case c6

Case Is = 1: letr6 = " مليار"

Case Is = 2: letr6 = " ملياران"

Case 3 To 10: letr6 = aword(c6) + " مليارات"

Case Is > 10: letr6 = aword(c6) + " ملياراً"[/left]


[left]End Select[/left]


[left]If letr6 <> "" And letr5 <> "" Then letr6 = letr6 + " و " + letr5

If letr6 = "" Then letr6 = letr5[/left]


[left]'=====[/left]


[left]c7 = Val(Mid(c, 1, 3))[/left]


[left]Select Case c7

Case Is = 1: letr7 = " ترليون"

Case Is = 2: letr7 = " ترليونان"

Case 3 To 10: letr7 = aword(c7) + " تريليونات"

Case Is > 10: letr7 = aword(c7) + " تريليوناً"[/left]


[left]End Select[/left]


[left]If letr7 <> "" And letr6 <> "" Then letr7 = letr7 + " و " + letr6

If letr7 = "" Then letr7 = letr6[/left]


[left]aword = letr7[/left]


[left]

End Function[/left]


[left]

' by Hashim Ahmed Taha

Public Sub Main()[/left]


[left]

Selection.HomeKey Unit:=wdLine

    Selection.EndKey Unit:=wdLine, Extend:=wdExtend

    sWhole = Selection.Text


    Selection.TypeText word(sWhole)[/left]


[left]End Sub[/left]


[left]

[hat]

عفواً .. أحذف جميع الكلمات التي بين [ ] والقوسين ايضاً من الكود

مثلا [ /left] و

[تومي محمد]

مازالت المشكلة قائمة

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

[hat]

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

الاخ تومي ما هو نوع الاوفيس الذي تستخدمه ؟؟ ونوع الويندوز ؟

شكرا لك

[حيدر عبده]

مشكور بارك الله فيك

[تومي محمد]

نوع الاوفيس الذي عندي اوفيس عربي 2007

والويندوز الذي عندي windows xp 2000 pack 2

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

[ربيع القيسي]

ممكن صور كيف  تثبيت

 الدالة 

رجاءا

[حمادة عمر]

معلومة جميلة وشرح وافي

جزاك الله خيرا