16-03-14, 04:14 PM
السلام عليكم ورحمه الله وبركاته
مشكلتى الان هى تفقيط الارقام الى حروف فى الفيجول بيسك
عندما يتم تفقيط الارقام يتم حفظ جميع محتويات التكست داخل قاعده البيانات ماعدا التكست الذي يتم فيه التفقيط باللغه العربيه
ده كود المديول
مشكلتى الان هى تفقيط الارقام الى حروف فى الفيجول بيسك
عندما يتم تفقيط الارقام يتم حفظ جميع محتويات التكست داخل قاعده البيانات ماعدا التكست الذي يتم فيه التفقيط باللغه العربيه
ده كود المديول
PHP كود :
Dim Sx As Integer
Dim Num As String
Const Mony0 = "فقط صفر جنيه مصرى"
Const Mony1 = "فقط واحد جنيه مصرى"
Const Mony2 = "فقط جنيهان مصرى"
Const Mony = " جنيه مصري "
Const Not_Yet = " لا غير "
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) = frst1(Indx(1), sex)
If (Right(ns, 1) = 1) And (Mid$(Right(ns, 2), 1, 1) = 0) Then
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) = 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(9, 1) As String
Static SecondArray(9, 1) As String
Static ThirdArray(9) As String
ReDim Parts(4) As String
ReDim PartStr(-3 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
'sex=0 مذكر
'sex= 1 مؤنث
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(3, 0) = "ثلاثة "
FirstArray1(4, 0) = "أربعة ": FirstArray1(5, 0) = "خمسة ": FirstArray1(6, 0) = "ستة "
FirstArray1(7, 0) = "سبعة ": FirstArray1(8, 0) = "ثمانية ": FirstArray1(9, 0) = "تسعة "
FirstArray1(1, 1) = "إحدى ": FirstArray1(2, 1) = "اثنتا ": FirstArray1(3, 1) = "ثلاثة "
FirstArray1(4, 1) = "أربعة ": FirstArray1(5, 1) = "خمسة ": FirstArray1(6, 1) = "ستة "
FirstArray1(7, 1) = "سبعة ": FirstArray1(8, 1) = "ثمانية ": FirstArray1(9, 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 = "فقط صفر دولار أمريكي لا غير"
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 = 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) Or (Len(PartStr(i - 2)) > 0) Or (Len(PartStr(i - 3)) > 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
If (Right(Val(Trim(Text1)), 2) > 2) And (Right(Val(Trim(Text1)), 2) < 11) Then
WriteNo = txt & Mony & Not_Yet
Else
WriteNo = txt & Mony & Not_Yet
End If
End Function
''Text14(0).Text = WriteNo(Text16(1).Text, 1) TO CALL THE PROCEDRE
وده كود زر التحويل ليتم تحويل الرقم الى حروف
PHP كود :
Text14(0).Text = WriteNo(Text16(1).Text, 1)
فعلا بيتم التحويل لاكن لم يحفظ فى قاعده البيانات