+- منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب (http://vb4arb.com/vb)
+-- قسم : قسم قواعد البيانات (http://vb4arb.com/vb/forumdisplay.php?fid=40)
+--- قسم : قسم اسئلة التقارير والطباعة تحت بيئة الـ.NET (http://vb4arb.com/vb/forumdisplay.php?fid=71)
+--- الموضوع : تحويل الارقام الى حروف فى كريستال ريبورت (/showthread.php?tid=22652)
تحويل الارقام الى حروف فى كريستال ريبورت - abdhassan - 21-11-17
قمت باضافة الدالة التالية للكريستال ريبورت
لكن المشكلة الكريستال ريبورت لايدعم الاعادة الذاتية
او لم اعرف الطريقة لهذا كررت الدالة
كود :
Function myfuc100(d as number) as string
dim i as Number
Dim C As String
Dim C1 As String
dim x as Number
dim f as string
c=CStr(d)
c=Replace(c,",","")
x=instr(c,".")
c= Left(c,len(c)-3)
for i=1 to 12-len(c)
c="0"+c
next i
C1 = Mid(C, 12, 1)
Dim Letter1 As String
Select Case C1
Case "1"
Letter1 = "واحد"
Case "2"
Letter1 = "اثنان"
Case "3"
Letter1 = "ثلاثة"
Case "4"
Letter1 = "اربعة"
Case "5"
Letter1 = "خمسة"
Case "6"
Letter1 = "ستة"
Case "7"
Letter1 = "سبعة"
Case "8"
Letter1 = "ثمانية"
Case "9"
Letter1 = "تسعة"
End Select
Dim C2 As string
C2 = Mid(C, 11, 1)
Dim Letter2 As String
Select Case C2
Case "1"
Letter2 = "عشر"
Case "2"
Letter2 = "عشرون"
Case "3"
Letter2 = "ثلاثون"
Case "4"
Letter2 = "اربعون"
Case "5"
Letter2 = "خمسون"
Case "6"
Letter2 = "ستون"
Case "7"
Letter2 = "سبعون"
Case "8"
Letter2 = "ثمانون"
Case "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
Dim C3 As Number
C3 = Val(Mid(C, 10, 1))
Dim Letter3 As String
Select Case C3
Case 1
Letter3 = "مائة"
Case 2
Letter3 = "مئتان"
Case 3,4,5,6,7,8,9
f=myfuc1001(C3)
Letter3 = left(f, Len(f) - 1) + "مائة"
End Select
If Letter3 <> "" And Letter2 <> "" Then Letter3 = Letter3 + " و" + Letter2
If Letter3 = "" Then Letter3 = Letter2
Dim C4 As Number
C4 = Val(Mid(C, 7, 3))
Dim Letter4 As String
Select Case C4
Case 1
Letter4 = "الف"
Case 2
Letter4 = "الفان"
Case 3 To 10
Letter4 = myfuc1001(C4) + " آلاف"
Case Is > 10
Letter4 = myfuc1001(C4) + " الف"
End Select
If Letter4 <> "" And Letter3 <> "" Then Letter4 = Letter4 + " و" + Letter3
If Letter4 = "" Then Letter4 = Letter3
Dim C5 As Number
C5 = Val(Mid(C, 4, 3))
Dim Letter5 As String
Select Case C5
Case 1
Letter5 = "مليون"
Case 2
Letter5 = "مليونان"
Case 3 To 10
Letter5 = myfuc1001(C5) + " ملايين"
Case Is > 10
Letter5 = myfuc1001(C5) + " مليون"
End Select
If Letter5 <> "" And Letter4 <> "" Then Letter5 = Letter5 + " و" + Letter4
If Letter5 = "" Then Letter5 = Letter4
Dim C6 As Number
C6 = Val(Mid(C, 1, 3))
Dim Letter6 As String
Select Case C6
Case 1
Letter6 = "مليار"
Case 2
Letter6 = "ملياران"
Case Is > 2
Letter6 = myfuc1001(C6) + " مليار"
End Select
If Letter6 <> "" And Letter5 <> "" Then Letter6 = Letter6 + " و" + Letter5
If Letter6 = "" Then Letter6 = Letter5
myfuc100 =Letter6
end function
كود :
Function myfuc1001(d as number) as string
dim i as Number
Dim C As String
Dim C1 As String
dim x as Number
dim f as string
c=CStr(d)
c=Replace(c,",","")
x=instr(c,".")
c= Left(c,len(c)-3)
for i=1 to 12-len(c)
c="0"+c
next i
C1 = Mid(C, 12, 1)
Dim Letter1 As String
Select Case C1
Case "1"
Letter1 = "واحد"
Case "2"
Letter1 = "اثنان"
Case "3"
Letter1 = "ثلاثة"
Case "4"
Letter1 = "اربعة"
Case "5"
Letter1 = "خمسة"
Case "6"
Letter1 = "ستة"
Case "7"
Letter1 = "سبعة"
Case "8"
Letter1 = "ثمانية"
Case "9"
Letter1 = "تسعة"
End Select
Dim C2 As string
C2 = Mid(C, 11, 1)
Dim Letter2 As String
Select Case C2
Case "1"
Letter2 = "عشر"
Case "2"
Letter2 = "عشرون"
Case "3"
Letter2 = "ثلاثون"
Case "4"
Letter2 = "اربعون"
Case "5"
Letter2 = "خمسون"
Case "6"
Letter2 = "ستون"
Case "7"
Letter2 = "سبعون"
Case "8"
Letter2 = "ثمانون"
Case "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
Dim C3 As Number
C3 = Val(Mid(C, 10, 1))
Dim Letter3 As String
Select Case C3
Case 1
Letter3 = "مائة"
Case 2
Letter3 = "مئتان"
Case 3,4,5,6,7,8,9
f=myfuc1001(C3)
' Letter3 = Left(f, Len(f) - 1) + "مائة"
Letter3 = f+ "مائة"
End Select
If Letter3 <> "" And Letter2 <> "" Then Letter3 = Letter3 + " و" + Letter2
If Letter3 = "" Then Letter3 = Letter2
Dim C4 As Number
C4 = Val(Mid(C, 7, 3))
Dim Letter4 As String
Select Case C4
Case 1
Letter4 = "الف"
Case 2
Letter4 = "الفان"
Case 3 To 10
Letter4 = myfuc1001(C4) + " آلاف"
Case Is > 10
Letter4 = myfuc1001(C4) + " الف"
End Select
If Letter4 <> "" And Letter3 <> "" Then Letter4 = Letter4 + " و" + Letter3
If Letter4 = "" Then Letter4 = Letter3
Dim C5 As Number
C5 = Val(Mid(C, 4, 3))
Dim Letter5 As String
Select Case C5
Case 1
Letter5 = "مليون"
Case 2
Letter5 = "مليونان"
Case 3 To 10
Letter5 = myfunc(C5) + " ملايين"
Case Is > 10
Letter5 = myfunc(C5) + " مليون"
End Select
If Letter5 <> "" And Letter4 <> "" Then Letter5 = Letter5 + " و" + Letter4
If Letter5 = "" Then Letter5 = Letter4
Dim C6 As Number
C6 = Val(Mid(C, 1, 3))
Dim Letter6 As String
Select Case C6
Case 1
Letter6 = "مليار"
Case 2
Letter6 = "ملياران"
Case Is > 2
Letter6 = myfunc(C6) + " مليار"
End Select
If Letter6 <> "" And Letter5 <> "" Then Letter6 = Letter6 + " و" + Letter5
If Letter6 = "" Then Letter6 = Letter5
myfuc1001 =Letter6
end function
RE: تحويل الارقام الى حروف فى كريستال ريبورت - msakr - 27-01-19
كيف اضيف هذه الداله للكريستال ريبورت