تقييم الموضوع :
  • 1 أصوات - بمعدل 1
  • 1
  • 2
  • 3
  • 4
  • 5
[كود] مشكله فى كود تفقيط الارقام الى حروف
#1
Thumbs Up 
السلام عليكم ورحمه الله وبركاته
مشكلتى الان هى تفقيط الارقام الى حروف فى الفيجول بيسك

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

ده كود المديول


PHP كود :
Dim Sx As Integer
Dim Num 
As String
Const Mony0 "فقط صفر جنيه مصرى"
Const Mony1 "فقط واحد جنيه مصرى"
Const Mony2 "فقط جنيهان مصرى"
Const Mony " جنيه مصري "
Const Not_Yet " لا غير "



Function GetNo(ns As Stringsex As IntegerPower As Integerfrst() As Stringfrst1() As Stringscnd() As Stringthrd() As String) As String

  Dim Lngth 
As IntegerInvSex  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$(nsLngth1))
  
TmpArray(0) = frst1(Indx(1), sex)
  If (
Right(ns1) = 1) And (Mid$(Right(ns2), 11) = 0Then
  TmpArray
(0) = frst(Indx(1), sex)
  
End If
  
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 '
العشرات من 1 إلى تسعة
      TmpArray
(0) = TmpArray(0) + " و"
    
ElseIf (Indx(1) = 1) And (Indx(2) = 1Then  'أحد عشر
      TmpArray(0) = frst1(1, sex)
    ElseIf (Indx(1) = 2) And (Indx(2) = 1) Then ' 
اثنا عشر
      TmpArray
(0) = frst1(2sex)
    
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) = 0Then
      GetNo 
" ألف "
    
ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
" ألفان "
    
ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
TmpArray(0) & " آلاف "
    
ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0Then
      GetNo 
TmpArray(2) & TmpArray(0) & TmpArray(1) & " آلاف "
    
ElseIf (Indx(1) = 0) And (Indx(2) = 0) And (Indx(3) = 0Then
      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) = 0Then
      GetNo 
" مليون "
    
ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
" مليونان "
    
ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
TmpArray(0) & " ملايين "
    
ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0Then
      GetNo 
TmpArray(2) & TmpArray(0) & TmpArray(1) & " ملايين "
    
ElseIf (Indx(1) = 0) And (Indx(2) = 0) And (Indx(3) = 0Then
      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) = 0Then
      GetNo 
" مليار "
    
ElseIf (Indx(1) = 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
" ملياران "
    
ElseIf (Indx(1) > 2) And (Indx(2) = 0) And (Indx(3) = 0Then
      GetNo 
TmpArray(0) & " مليارات "
    
ElseIf (Indx(1) = 0) And (Indx(2) = 1) And (Indx(3) = 0Then
      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 Stringsex As Integer) As String
  
  
Static FirstArray(91) As String
  
Static FirstArray1(91)  As String
  
Static SecondArray(91) As String
  
Static ThirdArray(9) As String
  
  ReDim Parts
(4) As String
  ReDim PartStr
(-3 To 3) As String
  
  Dim Length 
As IntegerAs IntegerTempLength As Integer
  Dim NoString 
As Stringpos  As Integer
  Dim AfterPoint 
As String
  Dim txt 
As String

  
'sex=0 مذكر
  '
sex1 مؤنث

  FirstArray
(10) = "واحد "FirstArray(20) = "اثنان "FirstArray(30) = "ثلاثة "
  
FirstArray(40) = "أربعة "FirstArray(50) = "خمسة "FirstArray(60) = "ستة "
  
FirstArray(70) = "سبعة "FirstArray(80) = "ثمانية "FirstArray(90) = "تسعة "

  
FirstArray(11) = "واحدة "FirstArray(21) = "اثنتان "FirstArray(31) = "ثلاثة "
  
FirstArray(41) = "أربعة "FirstArray(51) = "خمسة "FirstArray(61) = "ستة "
  
FirstArray(71) = "سبعة "FirstArray(81) = "ثمانية "FirstArray(91) = "تسعة "
                                                        
  
FirstArray1(10) = "أحد "FirstArray1(20) = "اثنا "FirstArray1(30) = "ثلاثة "
  
FirstArray1(40) = "أربعة "FirstArray1(50) = "خمسة "FirstArray1(60) = "ستة "
  
FirstArray1(70) = "سبعة "FirstArray1(80) = "ثمانية "FirstArray1(90) = "تسعة "

  
FirstArray1(11) = "إحدى "FirstArray1(21) = "اثنتا "FirstArray1(31) = "ثلاثة "
  
FirstArray1(41) = "أربعة "FirstArray1(51) = "خمسة "FirstArray1(61) = "ستة "
  
FirstArray1(71) = "سبعة "FirstArray1(81) = "ثمانية "FirstArray1(91) = "تسعة "
  
  
SecondArray(10) = "عشر "SecondArray(20) = "عشرون "SecondArray(30) = "ثلاثون "
  
SecondArray(40) = "أربعون "SecondArray(50) = "خمسون "SecondArray(60) = "ستون "
  
SecondArray(70) = "سبعون "SecondArray(80) = "ثمانون "SecondArray(90) = "تسعون "

  
SecondArray(11) = "عشرة "SecondArray(21) = "عشرون "SecondArray(31) = "ثلاثون "
  
SecondArray(41) = "أربعون "SecondArray(51) = "خمسون "SecondArray(61) = "ستون "
  
SecondArray(71) = "سبعون "SecondArray(81) = "ثمانون "SecondArray(91) = "تسعون "


  
ThirdArray(1) = "مائة "ThirdArray(2) = "مائتان "ThirdArray(3) = "ثلاثمائة "
  
ThirdArray(4) = "أربعمائة "ThirdArray(5) = "خمسمائة "ThirdArray(6) = "ستمائة "
  
ThirdArray(7) = "سبعمائة "ThirdArray(8) = "ثمانمائة "ThirdArray(9) = "تسعمائة "
  
  
txt ""= -1

  
If Val(no) = 0 Then 'هل العدد المدخل صفر
    '
WriteNo "فقط صفر دولار أمريكي لا غير"
     
WriteNo Mony0 Not_Yet
    
    
Exit Function
  
End If
  
  If 
Val(no) = 1 Then
   
' WriteNo = "فقط دولار أمريكي واحد لا غير"
     WriteNo = Mony1 & Not_Yet
    
    Exit Function
  End If
  
  If Val(no) = 2 Then
    WriteNo = Mony2 & Not_Yet
    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 
1
    Parts
(i) = Right$(NoString3)
    
NoString$ = Left$(NoStringTempLength)
  
Loop
  Parts
(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 3 To 0 Step -1
    
If Len(PartStr(i)) > 0 Then
      
If (Len(PartStr(1)) > 0) Or (Len(PartStr(2)) > 0) Or (Len(PartStr(3)) > 0Then
        txt 
txt " " PartStr(i) & "و"
      
Else
        
txt txt " " PartStr(i) & " "
      
End If
    
End If
  
Next
  
If Val(AfterPoint) > 0 Then
    txt 
txt "و" GetNo(AfterPointsex, -1FirstArray(), FirstArray1(), SecondArray(), ThirdArray())
  
End If
  If (
Right(Val(Trim(Text1)), 2) > 2) And (Right(Val(Trim(Text1)), 2) < 11Then
  WriteNo 
txt Mony Not_Yet
  
Else
   
WriteNo txt Mony Not_Yet
 
  End 
If
End Function

''Text14(0).Text WriteNo(Text16(1).Text1TO CALL THE PROCEDRE 

وده كود زر التحويل ليتم تحويل الرقم الى حروف
PHP كود :
Text14(0).Text WriteNo(Text16(1).Text1

فعلا بيتم التحويل لاكن لم يحفظ فى قاعده البيانات
الرد }}}
تم الشكر بواسطة:
#2
جرب

text15.text=text14(0).text

و قم بادخال text15 بدلا عن التكست14(0)
الرد }}}
تم الشكر بواسطة:
#3
جربت برضوا
التفقيط يظهر مظبوط لاكن عند الحفظ كل البيانات تحفظ الا التفقيط
لة كتبته يدوي بيتحفظ عادى لاكن عن طريق الداله لم يحفظ
Confused
الرد }}}
تم الشكر بواسطة:
#4
ارفق لنا مثالك لنجرب عليه و نعدله
الرد }}}
تم الشكر بواسطة:
#5
مرفق اداة تفقيط اتمني ان تفيدك
الرد }}}
تم الشكر بواسطة:
#6
بالمرفقااااااااااات


الملفات المرفقة
.rar   ar.rar (الحجم : 14.95 ك ب / التحميلات : 222)
الرد }}}
تم الشكر بواسطة:
#7
مساحه الملف كبيره جداً ولا يمكن ارفقها للاسف


يوجد صوره بالمرفقات
بان مبلغ التفقيط يظهر فى التكست وعند عمليه الحفظ
لم يحفظ التفقيط فى قاعده البيانات Blush


الملفات المرفقة صورة/صور
   
الرد }}}
تم الشكر بواسطة:
#8
تفضل أخي قمت بعمل مثال لك

اتمنا الفائدة للجميع


الملفات المرفقة
.rar   التفقيط.rar (الحجم : 12.21 ك ب / التحميلات : 212)
[صورة مرفقة: images?q=tbn:ANd9GcT72OLJW7D1E5QW-HUeWeJ...TGoNeg2jnQ]
الرد }}}
تم الشكر بواسطة: king2512010
#9
تفضل أخي بطريقة Adodc


الملفات المرفقة
.rar   التفقيط.rar (الحجم : 15.2 ك ب / التحميلات : 166)
[صورة مرفقة: images?q=tbn:ANd9GcT72OLJW7D1E5QW-HUeWeJ...TGoNeg2jnQ]
الرد }}}
تم الشكر بواسطة: eng_elsawy
#10
السلام عليكم
موديل كامل لتحويل الارقام الى حروف
بستخدمه من 2011 فى برنامج خاص بى وشغال 100%Smile


الملفات المرفقة
.rar   convertnum.rar (الحجم : 1.01 ك ب / التحميلات : 234)
الرد }}}
تم الشكر بواسطة: eng_elsawy


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
Question [vb6.0] عندي مشكلة في هذا الكود حيث انه لا يقبل الا رقم فقط اريد ان يقبل الارقام والاحرف ؟ Microformt 1 269 25-10-23, 04:10 PM
آخر رد: Amir_Alzubidy
Information [vb6.0] كيف اجعل الارقم في التقرير باء الغه الانجليزية حتى لو كان نظام الارقام في الويندوز Microformt 0 179 16-08-23, 10:41 AM
آخر رد: Microformt
Photo [vb6.0] هناك مشكله اكتيف ريبورت يحث يظهر الخط عند عرض التقرير بشكل مكبر ومد في الحرف ؟؟ Microformt 7 768 03-02-23, 01:55 PM
آخر رد: Taha Okla
  مشكله في كود اتصال بجهاز البصمه ahmed1900 0 390 18-01-23, 11:54 AM
آخر رد: ahmed1900
  مشكلة تفقيط في تقرير ‪Active Report ahmed250 8 1,694 03-12-21, 11:04 PM
آخر رد: zainabaza
  مشكله في تقرير المبيعات ahmed201 3 1,631 21-02-21, 09:47 PM
آخر رد: ahmed201
  مشكله في كواد بحث في قاعدة بيانات اكسس ahmed250 2 1,619 07-08-20, 09:50 AM
آخر رد: ahmed250
  مشكله في كود اضافه ملف pdf في قاعدة بيانات اكسس وإستدعاءه ahmed250 1 1,504 03-07-20, 11:23 AM
آخر رد: Ahmed_Mansoor
  [vb6.0] مشكله ado اداه فراس محي 4 1,750 20-02-20, 09:55 AM
آخر رد: فراس محي
  مشكله فى لعبه مبرمجه على الفيجوال بيسك خالد كامل1 0 1,294 19-12-19, 09:53 PM
آخر رد: خالد كامل1

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم