تحويل الرقم الى كتابة

انت بحاجة الى عمل مودول لتمرير الرقم . وارجاع النص .

وهذا الكود طويل . وسوف احاول كتابته .

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

لقد بحثت عن هذا الموضوع فلم أجده رغم أنني كتبت في محرك البحث (تحويل) و ( تحويل الرقم ) ولكن دون فائده ... أرجوا ممن يعرف عنوان الموضوع على هذا المنتدى أن يضع رابط للموضوع . وشكرا

الأخوه الكرام أنا أيضا أبحث عن هذا الموضوع ولم أجده بالبحث في هذا الموقع الرجاء من المشرفين أو الأعضاء وضع رابط لهذا الموضوع وشكرا

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

Public Function Horof(X)
     ' هذه المديول تقوم بكتابة الأرقام بالعربية وبالريال العماني
      ma = " ريال"
      Mi = " بيسة"
      ml = "بيسات"
      Mn = "ريالات"
      
      N = Int(X)
      b = Val(Right(Format(X, "000000000000.000"), 3))
      r = SHorof(N)
      b1 = SHorof(b)
      If r <> "" And b >= 0 Then Result = r & ma & " و " & b1 & Mi & " فقط لا غير "
      'If r <> "" And (b <= 9 And b >= 1) Then result = r & ma & " و" & b1 & ml & " فقط لا غير "
      If r = "" And b <> 0 Then Result = b1 & Mi & " فقط لا غير "
      If r = "" And b = 0 Then Result = " صفر"
      If r <> "" And b = 0 Then Result = r & ma & " فقط لا غير "
      Horof = Result
      
End Function

Private Function SHorof(X)
      
      N = Int(X)
      C = Format(N, "000000000000")
      C1 = Val(Mid(C, 12, 1))
      Select Case C1
            Case Is = 1: Letter1 = "واحد"
            Case Is = 2: Letter1 = "اثنان"
            Case Is = 3: Letter1 = "ثلاثة"
            Case Is = 4: Letter1 = "اربعة"
            Case Is = 5: Letter1 = "خمسة"
            Case Is = 6: Letter1 = "ستة"
            Case Is = 7: Letter1 = "سبعة"
            Case Is = 8: Letter1 = "ثمانية"
            Case Is = 9: Letter1 = "تسعة"
      End Select
      
      C2 = Val(Mid(C, 11, 1))
      Select Case C2
            Case Is = 1: Letter2 = "عشر"
            Case Is = 2: Letter2 = "عشرون"
            Case Is = 3: Letter2 = "ثلاثون"
            Case Is = 4: Letter2 = "اربعون"
            Case Is = 5: Letter2 = "خمسون"
            Case Is = 6: Letter2 = "ستون"
            Case Is = 7: Letter2 = "سبعون"
            Case Is = 8: Letter2 = "ثمانون"
            Case Is = 9: Letter2 = "تسعون"
      End Select
      
      If Letter1 <> "" And C2 > 1 Then Letter2 = Letter1 + " و" + Letter2
      If Letter2 = "" Then Letter2 = Letter1
      If C1 = 0 And C2 = 1 Then Letter2 = Letter2 + "ة"
      If C1 = 1 And C2 = 1 Then Letter2 = "احدى عشر"
      If C1 = 2 And C2 = 1 Then Letter2 = "اثنى عشر"
      If C1 > 2 And C2 = 1 Then Letter2 = Letter1 + " " + Letter2
      C3 = Val(Mid(C, 10, 1))
      Select Case C3
            Case Is = 1: Letter3 = "مائة"
            Case Is = 2: Letter3 = "مئتان"
            Case Is > 2: Letter3 = Left(SHorof(C3), Len(SHorof(C3)) - 1) + "مائة"
      End Select
      If Letter3 <> "" And Letter2 <> "" Then Letter3 = Letter3 + " و" + Letter2
      If Letter3 = "" Then Letter3 = Letter2
      
      C4 = Val(Mid(C, 7, 3))
      Select Case C4
            Case Is = 1: Letter4 = "الف"
            Case Is = 2: Letter4 = "الفان"
            Case 3 To 10: Letter4 = SHorof(C4) + " آلاف"
            Case Is > 10: Letter4 = SHorof(C4) + " الف"
      End Select
      If Letter4 <> "" And Letter3 <> "" Then Letter4 = Letter4 + " و" + Letter3
      If Letter4 = "" Then Letter4 = Letter3
      C5 = Val(Mid(C, 4, 3))
      Select Case C5
            Case Is = 1: Letter5 = "مليون"
            Case Is = 2: Letter5 = "مليونان"
            Case 3 To 10: Letter5 = SHorof(C5) + " ملايين"
            Case Is > 10: Letter5 = SHorof(C5) + " مليون"
      End Select
      If Letter5 <> "" And Letter4 <> "" Then Letter5 = Letter5 + " و" + Letter4
      If Letter5 = "" Then Letter5 = Letter4
      
      C6 = Val(Mid(C, 1, 3))
      Select Case C6
            Case Is = 1: Letter6 = "مليار"
            Case Is = 2: Letter6 = "ملياران"
            Case Is > 2: Letter6 = SHorof(C6) + " مليار"
      End Select
      If Letter6 <> "" And Letter5 <> "" Then Letter6 = Letter6 + " و" + Letter5
      If Letter6 = "" Then Letter6 = Letter5
      SHorof = Letter6
      
End Function

فقط مرر القيمة بكتابة الكود التالي :

Call Horof (مرر القيمة هنا )

ويوجد مثال كامل ببرنامج مصانع الطابوق بالتوقيع أدناه

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

اعتقد ان هذه العمليه اسمها (تفقيط الارقام )

وهذا المنتدى ومنتدى فيجول بيسك للعرب ملئيان بمثل هذا النوع من المشاركات

يتم البحث بكلمة تفقيط فقط

هذا بحث في هذا المنتدى

/index.ph...%CA%DD%DE%ED%D8

وهذا بحث في موقع فيجول بيسك للعرب www.vb4arab.com

http://www.vb4arab.com/vb/search.php?s=&ac...rder=descending

هذا ايضا مثال آخر ,

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

يجب عليك أن تضيف المودول المرفق مع مشروعك .

بالنسبة للمودول هذا هو الكود .

Function GetNo(ns As String, sex As Integer, Power As Integer, frst() As String, frst1() As String, scnd() As String, thrd() As String) As String
  Dim Lngth As Integer, InvSex  As Integer
  ReDim Indx(3) As Integer
  ReDim TmpArray(2) As String
  Dim tms As String

  If sex = 0 Then
    InvSex = 1
  Else
    InvSex = 0
  End If

  Lngth = Len(ns)
  
  Indx(1) = Val(Mid$(ns, Lngth, 1))
  TmpArray(0) = frst(Indx(1), sex)
  Lngth = Lngth - 1
  If Lngth > 0 Then
    
    Indx(2) = Val(Mid$(ns, Lngth, 1))
    If TmpArray(0) <> "" Then
      TmpArray(1) = scnd(Indx(2), InvSex)
    Else
      TmpArray(1) = scnd(Indx(2), sex)
    End If
    If (Indx(2) > 1) And (TmpArray(0) <> "") Then
      TmpArray(0) = TmpArray(0) + " æ"
    ElseIf (Indx(1) = 1) And (Indx(2) = 1) Then
      TmpArray(0) = frst1(1, sex)
    ElseIf (Indx(1) = 2) And (Indx(2) = 1) Then
      TmpArray(0) = frst1(2, sex)
    End If
    Lngth = Lngth - 1
    If Lngth > 0 Then
    
      Indx(3) = Val(Mid$(ns, Lngth, 1))
      TmpArray(2) = thrd(Indx(3))
      If (Indx(3) > 0) And ((TmpArray(0) <> "") Or (TmpArray(1) <> "")) Then TmpArray(2) = TmpArray(2) + " æ"
    Else
      GoTo last
    End If
  Else
    GoTo last
  End If
  
last:
Select Case Power
  Case Is = -1
    tms = TmpArray(2) & TmpArray(0) & TmpArray(1)
    If (TmpArray(0) <> "") And (TmpArray(1) = "") And (TmpArray(2) = "") Then
      GetNo = tms & " ÈÇáÚÔÑÉ"
    ElseIf (TmpArray(0) <> "") And (TmpArray(1) <> "") And (TmpArray(2) = "") Then
       GetNo = tms & " ÈÇáãÆÉ"
    ElseIf (TmpArray(0) <> "") And (TmpArray(1) <> "") And (TmpArray(2) <> "") Then
       GetNo = tms & " ÈÇáÃáÝ"
    End If
  Case Is = 0
    GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1)
  Case Is = 1
    If (Indx(1) = 1) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ÃáÝ "
    ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ÃáÝÇä "
    ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = TmpArray(0) & " ÂáÇÝ "
    ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0) Then
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ÂáÇÝ "
    ElseIf (Indx(1) = 0) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1)
    Else
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ÃáÝ "
    End If
  Case Is = 2
    If (Indx(1) = 1) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ãáíæä "
    ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ãáíæäÇä "
    ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = TmpArray(0) & " ãáÇííä "
    ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0) Then
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ãáÇííä "
    ElseIf (Indx(1) = 0) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1)
    Else
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ãáíæä "
    End If
  Case Is = 3
    If (Indx(1) = 1) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ãáíÇÑ "
    ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = " ãáíÇÑÇä "
    ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0) Then
      GetNo = TmpArray(0) & " ãáíÇÑÇÊ "
    ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0) Then
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ãáíÇÑÇÊ "
    Else
      GetNo = TmpArray(2) & TmpArray(0) & TmpArray(1) & " ãáíÇÑ "
    End If
 End Select
End Function
Function WriteNo(no As String, sex As Integer) As String
  
  Static FirstArray(9, 1) As String
  Static FirstArray1(2, 1)  As String
  Static SecondArray(9, 1) As String
  Static ThirdArray(9) As String
  
  ReDim Parts(4) As String
  ReDim PartStr(-1 To 3) As String
  
  Dim Length As Integer, i As Integer, TempLength As Integer
  Dim NoString As String, pos  As Integer
  Dim AfterPoint As String
  Dim txt As String


  FirstArray(1, 0) = "æÇÍÏ ": FirstArray(2, 0) = "ÇËäÇä ": FirstArray(3, 0) = "ËáÇËÉ "
  FirstArray(4, 0) = "ÃÑÈÚÉ ": FirstArray(5, 0) = "ÎãÓÉ ": FirstArray(6, 0) = "ÓÊÉ "
  FirstArray(7, 0) = "ÓÈÚÉ ": FirstArray(8, 0) = "ËãÇäíÉ ": FirstArray(9, 0) = "ÊÓÚÉ "

  FirstArray(1, 1) = "æÇÍÏÉ ": FirstArray(2, 1) = "ÇËäÊÇä ": FirstArray(3, 1) = "ËáÇË "
  FirstArray(4, 1) = "ÃÑÈÚ ": FirstArray(5, 1) = "ÎãÓ ": FirstArray(6, 1) = "ÓÊ "
  FirstArray(7, 1) = "ÓÈÚ ": FirstArray(8, 1) = "ËãÇä ": FirstArray(9, 1) = "ÊÓÚ "
                                                        
  FirstArray1(1, 0) = "ÃÍÏ ": FirstArray1(2, 0) = "ÇËäÇ "
  
  FirstArray1(1, 1) = "ÅÍÏì ": FirstArray1(2, 1) = "ÇËäÊÇ "
                     
  SecondArray(1, 0) = "ÚÔÑÉ ": SecondArray(2, 0) = "ÚÔÑæä ": SecondArray(3, 0) = "ËáÇËæä "
  SecondArray(4, 0) = "ÃÑÈÚæä ": SecondArray(5, 0) = "ÎãÓæä ": SecondArray(6, 0) = "ÓÊæä "
  SecondArray(7, 0) = "ÓÈÚæä ": SecondArray(8, 0) = "ËãÇäæä ": SecondArray(9, 0) = "ÊÓÚæä "

  SecondArray(1, 1) = "ÚÔÑ ": SecondArray(2, 1) = "ÚÔÑæä ": SecondArray(3, 1) = "ËáÇËæä "
  SecondArray(4, 1) = "ÃÑÈÚæä ": SecondArray(5, 1) = "ÎãÓæä ": SecondArray(6, 1) = "ÓÊæä "
  SecondArray(7, 1) = "ÓÈÚæä ": SecondArray(8, 1) = "ËãÇäæä ": SecondArray(9, 1) = "ÊÓÚæä "


  ThirdArray(1) = "ãÆÉ ": ThirdArray(2) = "ãÆÊÇä ": ThirdArray(3) = "ËáÇËãÆÉ "
  ThirdArray(4) = "ÃÑÈÚãÆÉ ": ThirdArray(5) = "ÎãÓãÇÆÉ ": ThirdArray(6) = "ÓÊãÆÉ "
  ThirdArray(7) = "ÓÈÚãÆÉ ": ThirdArray(8) = "ËãÇäãÇÆÉ ": ThirdArray(9) = "ÊÓÚãÆÉ "
  
  txt = "": i = -1

  If Val(no) = 0 Then
    WriteNo = "ÕÝÑ"
    Exit Function
  End If
  NoString = Trim(no)
  Length = Len(NoString)
  pos = InStr(NoString, ".")
  If pos > 0 Then
    AfterPoint = Right$(NoString, Length - pos)
    NoString = Left$(NoString, pos - 1)
    Length = Len(NoString)
  Else
    pos = InStr(NoString, ",")
    If pos > 0 Then
      AfterPoint = Right$(NoString, Length - pos)
      NoString = Left$(NoString, pos - 1)
      Length = Len(NoString)
    End If
  End If
  
  TempLength = Length
  Parts(0) = NoString
  Do While TempLength >= 3
    TempLength = TempLength - 3
    i = i + 1
    Parts(i) = Right$(NoString, 3)
    NoString$ = Left$(NoString, TempLength)
  Loop
  Parts(i + 1) = NoString
  For i = 0 To 3
    If Len(Parts(i)) > 0 Then
      PartStr(i) = GetNo(Parts(i), sex, i, FirstArray(), FirstArray1(), SecondArray(), ThirdArray())
    Else
      Exit For
    End If
  Next
  For i = 3 To 0 Step -1
    If Len(PartStr(i)) > 0 Then
      If Len(PartStr(i - 1)) > 0 Then
        txt = txt & " " & PartStr(i) & "æ"
      Else
        txt = txt & " " & PartStr(i) & " "
      End If
    End If
  Next
  If Val(AfterPoint) > 0 Then
    txt = txt & "æ" & GetNo(AfterPoint, sex, -1, FirstArray(), FirstArray1(), SecondArray(), ThirdArray())
  End If
  WriteNo = txt
End Function

أما بالنسبة للفورم

Dim Sx As Integer
Dim Num As String
Sub Form_Load()
  
Sx = 0

End Sub
Sub Text1_Change()
  
Num = Text1.Text
Label1.Caption = WriteNo(Num, Sx)

End Sub
Sub Option1_Click(Index As Integer)
  
Sx = Index
Label1.Caption = WriteNo(Num, Sx)

End Sub

او قم بتحميل المثال

no_string.zip