أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
khaled alborene مجدى يونس-- لا تميز خلال هذه الفترة YasserKhalil تصدير كل الجداول في اكسل كصور في مجلد يتم اختياره اكسيل اسئله واجابات


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



أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد

اولا من قائمة المطور تضغط علي وضع التصميم وتقوم بانشاء 2 مربع نص تقوم بانشاء مديول جديد من ووضع كود التفقيط بداخله [co ..



06-09-2018 10:58 مساء
emad eldwady
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-06-2018
رقم العضوية : 6651
المشاركات : 33
الجنس : ذكر
تاريخ الميلاد : 13-5-1986
يتابعهم : 5
يتابعونه : 0
قوة السمعة : 93
الاعجاب : 0
 offline 

اولا من قائمة المطور  تضغط علي وضع التصميم
وتقوم بانشاء 2 مربع نص
تقوم بانشاء مديول جديد  من ووضع كود التفقيط بداخله

'========================================================"
'      (دالة تحويل الرقم الى نص باللغة العربية (تفقيط      "
'                     kh_TextNum                         "
'========================================================"
'Num                     الرقم                           "
'========================================================"
'Sex                   جنس العملة                        "
'        FALSE   ( أو فارغ او صفر مذكر )                 "
'        TRUE   (  أو اي رقم غير الصفر مؤنث )             "
'========================================================"
'NCurr_Si        اسم العملة الرئيسية مفرد                "
'NCurr_Pl          اسم العملة الرئيسية جمع                "
'NCurrDec_Si           اسم العملة الكسرية                "
'Decimal_Count  طول الكسر افتراضـياً : بدون اظهار الكسر    "
'========================================================"
'            : للدلالة على تفقيط الكسر عين التالي            "
'NCurrDec_pl       اسم العملة الكسرية جمع                 "
'dSex               جنس عملة الكسر                       "
'        FALSE   ( أو فارغ او صفر مذكر )                 "
'        TRUE   (  أو اي رقم غير الصفر مؤنث )             "
'========================================================"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'                       ملاحظات
'  (اولاً : اذا اسم العملة ينتهي بالتاء المربوطة
'              يجب ان يكتب كذلك وليس بالهاء
'                -----------------------
'      ثانياً : العملة الافتراضية هي العملة السعودية
'               وجنس العملة والكسر مؤنث
'                -----------------------
'("" ثالثاً : امكانية إضافة كلمة بداية ونهاية النص (فارغة
Private Const MyBegTx As String = ""
Private Const MyEndTx As String = " فقط لاغير"
'                -----------------------
' MyTNum  رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت
'             للفئات الصفرية للرقم ادناه
Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات"
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
'==============================================================================================================================================="
Private Const wow As String * 2 = " و"
'==============================================================================================================================================="
 
Function CurrText(Num As String, _
Optional Sex As Boolean = True, _
Optional NCurr_Si As String = "ريال", _
Optional NCurr_Pl As String = "ريالات", _
Optional dSex As Boolean = True, _
Optional NCurrDec_Si As String = "هللة", _
Optional NCurrDec_Pl As String = "هللات", _
Optional Decimal_Count As Byte = 2) _
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 Txt = MyBegTx & "صفر " & NCurr_Si: GoTo kh_Exit
'======================================
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



ثم بعد ذللك تقوم بالضغط علي  مربع النص الاول مرتين وتكتب التالي
Private Sub TextBox1_Change()
TextBox2.Value = CurrText(TextBox1.Value)
End Sub

وتقفل  وضع التصميم  وتحفظ الملف بصيغه ماكرو للورد وبذلك يكون تم الانتهاء من الكود ويمكنك تجربة كتابة المبالغ
 
 
  كود تفقيط علي اللوورد.zip   تحميل zip مرات التحميل :(18)
الحجم :(33.357) KB








07-09-2018 12:29 صباحا
مشاهدة مشاركة منفردة [1]
ali mohamed ali
عضو محترف
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 911
الدولة : مصر
الجنس : ذكر
يتابعهم : 0
يتابعونه : 46
قوة السمعة : 4110
الاعجاب : 58
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
أحسنت استاذ عماد بارك الله فيك عمل رائع
ولو ممكن نقل الموضوع الى قسم وورد شروحات ودروس
جزاك الله كل خير



توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله



07-09-2018 06:24 صباحا
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 6174
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 383
قوة السمعة : 17042
الاعجاب : 141
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
بارك الله فيك أخي الكريم عماد وجزاك الله خيراً
موضوع جميل وخصوصاً أنه لم يتطرق أحد لموضوع التفقيط في برنامج الورد
تقبل تحياتي






17-10-2018 11:19 مساء
مشاهدة مشاركة منفردة [3]
مصطفى المياحي
عضو
معلومات الكاتب ▼
تاريخ الإنضمام : 17-10-2018
رقم العضوية : 8402
المشاركات : 8
الجنس : ذكر
تاريخ الميلاد : 15-5-1985
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 20
الاعجاب : 0
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
بارك الله فيك 






19-10-2018 08:14 مساء
مشاهدة مشاركة منفردة [4]
عبدالله الصاري
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-08-2017
رقم العضوية : 227
المشاركات : 90
الدولة : ليبيا
الجنس : ذكر
تاريخ الميلاد : 25-1-1964
يتابعهم : 6
يتابعونه : 2
قوة السمعة : 188
الاعجاب : 0
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
بارك الله فيك
ابداع






21-10-2018 09:05 مساء
مشاهدة مشاركة منفردة [5]
mahmoudelkomy
عضو
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 27-08-2017
رقم العضوية : 244
المشاركات : 12
الجنس : ذكر
تاريخ الميلاد : 17-5-1983
يتابعهم : 5
يتابعونه : 0
قوة السمعة : 26
الاعجاب : 0
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
رائع
 






22-10-2018 02:01 مساء
مشاهدة مشاركة منفردة [6]
محمد أبو العنين
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 159
المشاركات : 36
الجنس : ذكر
تاريخ الميلاد : 9-6-1969
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 62
الاعجاب : 2
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
جزاك الله خيرا
 






26-10-2018 01:16 مساء
مشاهدة مشاركة منفردة [7]
محمد حسن المحمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-08-2017
رقم العضوية : 80
المشاركات : 503
الجنس : ذكر
تاريخ الميلاد : 14-5-1965
الدعوات : 1
يتابعهم : 62
يتابعونه : 25
قوة السمعة : 2701
الاعجاب : 61
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
أحسنتم بارك الله فيكم 



توقيع :محمد حسن المحمد

الرفقُ ما كان في شيءٍ إلاَّ زانهُ ، وما نُزع من شيءٍ إلاَّ شانُه ،اللينُ في الخطاب ، البسمةُ الرائقةُ على المحيا، 
الكلمةُ الطيبةُ عند اللقاء ، هذه حُلَلٌ منسوجةٌ يرتديها السعداء




23-03-2019 07:26 مساء
مشاهدة مشاركة منفردة [8]
essam_bit
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 23-03-2019
رقم العضوية : 12061
المشاركات : 55
الجنس : ذكر
تاريخ الميلاد : 12-3-1968
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 16
الاعجاب : 1
 offline 
look/images/icons/i1.gif شرح لكيفيه عمل ماكرو وكود تفقيط علي الوورد
جزاك الله خيرا







الكلمات الدلالية
لكيفيه ، ماكرو ، وكود ، تفقيط ، الوورد ،


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.



الساعة الآن 06:50 صباحا

أعلن هنا
أعلن هنا
أعلن هنا