منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب

نسخة كاملة : مشكله فى كود تفقيط الارقام الى حروف
أنت حالياً تتصفح نسخة خفيفة من المنتدى . مشاهدة نسخة كاملة مع جميع الأشكال الجمالية .
الصفحات : 1 2
السلام عليكم ورحمه الله وبركاته
مشكلتى الان هى تفقيط الارقام الى حروف فى الفيجول بيسك

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

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


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

فعلا بيتم التحويل لاكن لم يحفظ فى قاعده البيانات
جرب

text15.text=text14(0).text

و قم بادخال text15 بدلا عن التكست14(0)
جربت برضوا
التفقيط يظهر مظبوط لاكن عند الحفظ كل البيانات تحفظ الا التفقيط
لة كتبته يدوي بيتحفظ عادى لاكن عن طريق الداله لم يحفظ
Confused
ارفق لنا مثالك لنجرب عليه و نعدله
مرفق اداة تفقيط اتمني ان تفيدك
بالمرفقااااااااااات
مساحه الملف كبيره جداً ولا يمكن ارفقها للاسف


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

اتمنا الفائدة للجميع
تفضل أخي بطريقة Adodc
السلام عليكم
موديل كامل لتحويل الارقام الى حروف
بستخدمه من 2011 فى برنامج خاص بى وشغال 100%Smile
الصفحات : 1 2