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

scorpion4ever · مايو 13, 2012

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

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

**ابوخليل** · مايو 13, 2012

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

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

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

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

**تومي محمد** · مايو 14, 2012

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

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

فما السبب

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

aliadel · مايو 22, 2012

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

hat · يونيو 15, 2012

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

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

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

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

[/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 · يونيو 15, 2012

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

مثلا [ /left] و

**تومي محمد** · يونيو 15, 2012

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

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

hat · يونيو 16, 2012

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

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

شكرا لك

حيدر عبده · أغسطس 5, 2012

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

**تومي محمد** · أغسطس 7, 2012

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

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

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

ربيع القيسي · ديسمبر 28, 2016

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

الدالة

رجاءا

**حمادة عمر** · أبريل 2, 2017

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

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

تسجيل الدخول

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

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

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

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

شارك

Join the conversation

محتوي مشابه

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

Important Information