كود تحويل الارقام الى حروف (( تفقيط ))

لكتابة الكود هنا

قم بلصق الكود ثم قم بتضليله كاملاً ثم من الأشكال الموجود في المنتدى تجد هذا الشكل # أضغط عليه والكود مضلل طبعاً بهذه الطريقة يكتب الكود في المنتدى

وشكرا لك

الأخ الكريم/ بدران

شكرا جزيلاً على أول مشاركة لك والله يوفقك في ما تبقى . (f)(f)(f)

[CODE]أشكرك ياأستاذ فهد الدوسري



وهذا كود تحويل الارقام الى حروف

---------------------------------------------

[CODE]Function Wrdx(T As String)

Dim i As Integer

Dim j  As Integer

Dim Wrd As String

Dim wrd1 As String

Dim wrd2 As String

Dim wrd3 As String

Dim wrd4 As String

Dim a(10) As String

Dim aa(10) As String

Dim sHund As String





Wrd = ""

wrd1 = ""

wrd2 = ""

wrd3 = ""

wrd4 = ""



a(1) = "واحد "

a(2) = "اثنين "

a(3) = "ثلاثة "

a(4) = "اربعة "

a(5) = "خمسة "

a(6) = "ستة "

a(7) = "سبعة "

a(8) = "ثمانية "

a(9) = "تسعة "



aa(1) = "عشر "

aa(2) = "عشرون "

aa(3) = "ثلاثون "

aa(4) = "اربعون "

aa(5) = "خمسون "

aa(6) = "ستون "

aa(7) = "سبعون "

aa(8) = "ثمانون "

aa(9) = "تسعون "



On Error Resume Next

If InStr(T, ".") > 0 Then

j = InStr(T, ".")



wrd4 = Mid(T, j + 1, 2)

If Len(wrd4) = 1 Then

    wrd4 = wrd4 & "0"

End If

T = Mid(T, 1, j - 1)

End If

i = Len(T)



Select Case i



Case 1

    Wrd = a(Val(T))

Case 2

    If Val(T) = 10 Then

      Wrd = "عشرة "

    ElseIf Val(T) = 11 Then

       Wrd = "احدعشر "

    ElseIf Val(T) = 12 Then

       Wrd = "اثنىعشر "

    ElseIf Val(T) < 20 Then

    

      Wrd = a(Val(Right(T, 1))) & aa(Val(Left(T, 1)))

      ElseIf Val(Right(T, 1)) = 0 Then

      Wrd = aa(Val(Left(T, 1)))

      Else

     Wrd = a(Val(Right(T, 1))) & "و" & aa(Val(Left(T, 1)))

     End If

Case 3

     If Val(Mid(T, 1, 1)) = 1 Then

        wrd1 = "مائة "

     ElseIf Val(Mid(T, 1, 1)) = 2 Then

        wrd1 = "مائتين "

     Else

        sHund = a(Val(Mid(T, 1, 1)))

        If Val(Mid(T, 1, 1)) = 8 Then

            sHund = Left(sHund, Len(sHund) - 3)

        Else

            sHund = Left(sHund, Len(sHund) - 2)

        End If

        wrd1 = sHund & "مائة" & " "

     End If

     

     T = Mid(T, 2, 2)

     If Val(T) = 10 Then

      Wrd = "عشرة "

    ElseIf Val(T) = 11 Then

       Wrd = "احدعشر "

    ElseIf Val(T) = 12 Then

       Wrd = "اثنىعشر "

    ElseIf Val(T) < 20 Then

    

      Wrd = a(Val(Right(T, 1))) & aa(Val(Left(T, 1)))

      ElseIf Val(Right(T, 1)) = 0 Then

      Wrd = aa(Val(Left(T, 1)))

      Else

     Wrd = a(Val(Right(T, 1))) & "و" & aa(Val(Left(T, 1)))

     End If

     If Wrd = "" Then

     Wrd = wrd1

     Else

     Wrd = wrd1 & "و" & Wrd

     End If

     

     

Case 4

     If Val(Mid(T, 1, 1)) = 1 Then

        wrd2 = "الف "

      ElseIf Val(Mid(T, 1, 1)) = 2 Then

         wrd2 = "الفين "

      Else

        wrd2 = a(Val(Mid(T, 1, 1))) & "الاف "

     End If

     T = Mid(T, 2, 3)

   

   If Val(Mid(T, 1, 1)) = 1 Then

        wrd1 = "مائة "

     ElseIf Val(Mid(T, 1, 1)) = 2 Then

        wrd1 = "مائتين "

     Else

     If Mid(T, 1, 1) > "0" Then

        



        If Val(Mid(T, 1, 1)) = 1 Then

           wrd1 = "مائة "

        ElseIf Val(Mid(T, 1, 1)) = 2 Then

           wrd1 = "مائتين "

        Else

           sHund = a(Val(Mid(T, 1, 1)))

           If Val(Mid(T, 1, 1)) = 8 Then

               sHund = Left(sHund, Len(sHund) - 3)

           Else

               sHund = Left(sHund, Len(sHund) - 2)

           End If

           wrd1 = sHund & "مائة" & " "

        End If

           

        End If

     End If

     T = Mid(T, 2, 2)

     If Val(T) = 10 Then

      Wrd = "عشرة "

    ElseIf Val(T) = 11 Then

       Wrd = "احدعشر "

    ElseIf Val(T) = 12 Then

       Wrd = "اثنىعشر "

    ElseIf Val(T) < 20 Then

    

      Wrd = a(Val(Right(T, 1))) & aa(Val(Left(T, 1)))

      ElseIf Val(Right(T, 1)) = 0 Then

      Wrd = aa(Val(Left(T, 1)))

      Else

     Wrd = a(Val(Right(T, 1))) & "و" & aa(Val(Left(T, 1)))

     End If

     If wrd1 <> "" Then

     wrd1 = "و" & wrd1

     End If

     If Wrd <> "" Then

     Wrd = "و" & Wrd

     End If

     Wrd = wrd2 & wrd1 & Wrd

Case 5

    If Val(Mid(T, 1, 2)) = 10 Then

      wrd2 = "عشرة الاف "

    ElseIf Val(Mid(T, 1, 2)) = 11 Then

       wrd2 = "احدعشرالفا "

    ElseIf Val(Mid(T, 1, 2)) = 12 Then

       wrd2 = "اثنىعشرالفا "

    ElseIf Val(Mid(T, 1, 2)) < 20 Then

    

      wrd2 = a(Val(Mid(T, 2, 1))) & aa(Val(Mid(T, 1, 1))) & "الفا "

      ElseIf Val(Mid(T, 2, 1)) = 0 Then

      wrd2 = aa(Val(Mid(T, 1, 1))) & "الفا "

      Else

     wrd2 = a(Val(Mid(T, 2, 1))) & "و" & aa(Val(Mid(T, 1, 1))) & "الفا "

     End If

     T = Mid(T, 3, 3)

   If Val(Mid(T, 1, 1)) = 1 Then

     wrd1 = "مائة "

     ElseIf Val(Mid(T, 1, 1)) = 2 Then

     wrd1 = "مائتين "

     Else

     If Mid(T, 1, 1) = "0" Then

          wrd1 = a(Val(Mid(T, 1, 1)))

     Else

        sHund = a(Val(Mid(T, 1, 1)))

        If Val(Mid(T, 1, 1)) = 8 Then

            sHund = Left(sHund, Len(sHund) - 3)

        Else

            sHund = Left(sHund, Len(sHund) - 2)

        End If

        wrd1 = sHund & "مائة" & " "

        

     End If

     End If

     T = Mid(T, 2, 2)

     If Val(T) = 10 Then

      Wrd = "عشرة "

    ElseIf Val(T) = 11 Then

       Wrd = "احدعشر "

    ElseIf Val(T) = 12 Then

       Wrd = "اثنىعشر "

    ElseIf Val(T) < 20 Then

    

      Wrd = a(Val(Right(T, 1))) & aa(Val(Left(T, 1)))

      ElseIf Val(Right(T, 1)) = 0 Then

      Wrd = aa(Val(Left(T, 1)))

      Else

     Wrd = a(Val(Right(T, 1))) & "و" & aa(Val(Left(T, 1)))

     End If

     If wrd1 <> "" Then

     wrd1 = "و" & wrd1

     End If

     If Wrd <> "" Then

     Wrd = "و" & Wrd

     End If

     Wrd = wrd2 & wrd1 & Wrd





Case 6



     If Val(Mid(T, 1, 1)) = 1 Then

     wrd3 = "مائة "

     ElseIf Val(Mid(T, 1, 1)) = 2 Then

     wrd3 = "مائتي "

     Else

     wrd3 = a(Val(Mid(T, 1, 1))) & "مائة "

     End If

     T = Mid(T, 2, 5)

    If Val(Mid(T, 1, 2)) = 10 Then

      wrd2 = "عشرة الاف "

    ElseIf Val(Mid(T, 1, 2)) = 11 Then

       wrd2 = "احدعشرالفا "

    ElseIf Val(Mid(T, 1, 2)) = 12 Then

       wrd2 = "اثنىعشرالفا "

    ElseIf Val(Mid(T, 1, 2)) < 20 Then

    

      wrd2 = a(Val(Mid(T, 2, 1))) & aa(Val(Mid(T, 1, 1))) & "الفا "

      ElseIf Val(Mid(T, 2, 1)) = 0 Then

      wrd2 = aa(Val(Mid(T, 1, 1))) & "الفا "

      Else

     wrd2 = a(Val(Mid(T, 2, 1))) & "و" & aa(Val(Mid(T, 1, 1))) & "الفا "

     End If

     T = Mid(T, 3, 3)

   If Val(Mid(T, 1, 1)) = 1 Then

     wrd1 = "مائة "

     ElseIf Val(Mid(T, 1, 1)) = 2 Then

     wrd1 = "مائتين "

     Else

     If Mid(T, 1, 1) = "0" Then

          wrd1 = a(Val(Mid(T, 1, 1)))

     Else

        sHund = a(Val(Mid(T, 1, 1)))

        If Val(Mid(T, 1, 1)) = 8 Then

            sHund = Left(sHund, Len(sHund) - 3)

        Else

            sHund = Left(sHund, Len(sHund) - 2)

        End If

        wrd1 = sHund & "مائة" & " "

        

     End If

     End If

     T = Mid(T, 2, 2)

     If Val(T) = 10 Then

      Wrd = "عشرة "

    ElseIf Val(T) = 11 Then

       Wrd = "احدعشر "

    ElseIf Val(T) = 12 Then

       Wrd = "اثنىعشر "

    ElseIf Val(T) < 20 Then

    

      Wrd = a(Val(Right(T, 1))) & aa(Val(Left(T, 1)))

      ElseIf Val(Right(T, 1)) = 0 Then

      Wrd = aa(Val(Left(T, 1)))

      Else

     Wrd = a(Val(Right(T, 1))) & "و" & aa(Val(Left(T, 1)))

     End If

     If wrd1 <> "" Then

     wrd1 = "و" & wrd1

     End If

     If Wrd <> "" Then

     Wrd = "و" & Wrd

     End If

     If wrd2 <> "الفا " Then

     wrd2 = "و" & wrd2

     End If

     Wrd = wrd3 & wrd2 & wrd1 & Wrd









End Select

If wrd4 = "" Then

    Wrdx = Wrd & "ريال"

Else

    Wrdx = Wrd & "ريال و " & wrd4 & " هللة"

End If

End Function

-------------------------------------------

اول شي -- تسوي وحدة نمطية جديدة ثم تلصق الكود فيها

ثم تسوي مربع نص جديد في النموذج او التقرير وتكتب فيه

=Wrdx([الراتب])

(( للتوضيح =Wrdx([اسم الحقل المراد تحويله الى حروف]) ))

وما إن تكتب الرقم في الحقل يتم مباشرة كتابته بالحروف في مربع النص الجديد

ولكم تحياتي وأشواقي

لقد لاحظت في البرنامج انك عندما تغير في الرقم ثم تذهب لمعاينة الطباعة

تجد ان الرقم لا يتغير وهذا لأنه لم يتم حفظ السجل قبل اجراء المعاينه لذا لابد

ان تذهب الى السجل التالي ثم تذهب للمعاينه لكي يتم الحفظ

ولقد اضفت كود حفظ السجل

وهذا هو البرنامج بعد التعديل

وأأسف لهذا العطل الفني

ولكم تحياتي

tafkit.zip

أولا شكرا لك ، و فى انتظار المزيد من المشاركات المفيدة

أعتقد أنه من المفيد توسيعها لتشمل الملايين

و بالمناسبةى هناك موضوع فى الارشيف ، يخص التفقيط به 12 دالة أخري

ربما تود تصفحه

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

مثال لابو هادي

http://www.arabteam2000.com/vb/showthread....%CA%DD%DE%ED%D8

و مرفق المثال الموجود فى الارشيف و الذي جمعت فيه الدوال التي أوردها الاخوة

punct.zip

شكرا لك استاذ محمد

الملف جدا رائع

وان شاء الله نتعلم من الكثير

تحياتي .