تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
التفقيط فى الكريستال ريبورت
#1
السلام عليكم
بحثت كثيرا عن طريقة التفقيط فى الكريستال ريبورت دون الوصول الى نتيجة
اريد formula  فى الكريستال ريبورت تظهر التفقيط باللغة العربية فى التقرير 
اتمني ان اجد الحل لديكم ان شاء الله
==============================================
سبحان الله وبحمده سبحان الله العظيم
الرد }}}
تم الشكر بواسطة:
#2
Public Class ClassConvertNO
Public Function ConvertToArabic(ByVal Str As String) As String
Dim IntStr As String = ""
Dim Frac As String = ""
Dim Result As String = ""
Dim L As Integer = Str.Length ' To Get The Length Of The Original Text
Dim M As Integer = Str.IndexOf(".") ' To Get The location Of Decimal Sign
If M > 0 Then
IntStr = Str.Remove(M, L - M) 'To Get Number Without Fractions
Frac = Str.Remove(0, M + 1) 'To Get Number With Fractions
ElseIf M = 0 Then : Frac = Str.Remove(0, M + 1)
ElseIf M < 0 Then : IntStr = Str : End If
'===============================
If IntStr <> Nothing Then IntStr = Get_IntStr_A(IntStr)
'my addation Is here
'----------------------------------
If Frac.Length = 1 Then Frac += "0"
'----------------------------------
If Frac <> Nothing Then Frac = Get_IntStr_A(Frac)
If IntStr <> Nothing Then Result = "# " & IntStr & " جنبه "
If Frac <> Nothing Then Result &= "و " & Frac & " قرش "
Result &= "فقط لا غير " & "#"
'===============================

Return Result
End Function

Private Function Get_IntStr_A(ByRef S As String) As String
Dim Result As String
'=============================================
'Chek If S >= 11 And <= 19
If Val(S) >= 11 And Val(S) <= 19 Then
S = Get_ValuesBN_11_19_A(S)
S = S.Remove(0, 1) : Return S : Exit Function
End If
'===============================================
Dim I As Integer
' Dim ROnes, RTens, RHun, RThus, RTenThus, RHunThus, RMln, RTenMln, RHunMln As String

Dim ROnes As String = "" : Dim RTens As String = "" : Dim RHun As String = ""
Dim RThus As String = "" : Dim RTenThus As String = "" : Dim RHunThus As String = ""
Dim RMln As String = "" : Dim RTenMln As String = "" : Dim RHunMln As String = ""
Dim SSS As String = "" : Dim J As Integer


Dim L As Integer = S.Length
For I = S.Length - 1 To 0 Step -1
If Val(S.Chars(I)) > 0 Then
Select Case I
'===============================================
Case L - 1 : ROnes = Get_Ones_A(S.Chars(I))
'===============================================
Case L - 2
For J = 0 To 7
If L = J + 2 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTens = Get_ValuesBN_11_19_A(SSS) : ROnes = Nothing
Else : RTens = Get_Tens_A(S.Chars(I)) : End If
'===============================================
Case L - 3 : RHun = Get_Hundreds_A(S.Chars(I))
'===============================================
Case L - 4 : RThus = Get_Thousands_A(S.Chars(I))
'===============================================
End Select
If L > 4 Then
Select Case I
'===============================================
Case L - 4 : RThus = Get_Ones_A(S.Chars(I))
If (S.Chars(L - 5)) = "0" Then
RThus &= " ألف "
End If
'===============================================
Case L - 5
For J = 0 To 4
If L = J + 5 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTenThus = Get_ValuesBN_11_19_A(SSS) : RThus = Nothing
Else : RTenThus = Get_Tens_A(S.Chars(I)) : End If
RTenThus &= " ألف "
'===============================================
Case L - 6 : RHunThus = Get_Hundreds_A(S.Chars(I))
If RTenThus = Nothing Then RHunThus &= " ألف "
'===============================================
Case L - 7
If L = 7 Then : RMln = Get_Ones_A(S.Chars(I)) & " مليون "
Else : RMln = Get_Ones_A(S.Chars(I)) : End If
'===============================================
Case L - 8
For J = 0 To 2
If L = J + 8 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTenMln = Get_ValuesBN_11_19_A(SSS) : RMln = Nothing
Else : RTenMln = Get_Tens_A(S.Chars(I)) : End If
If L = 8 Then RTenMln &= " مليون "
'===============================================
Case L - 9 : RHunMln = Get_Hundreds_A(S.Chars(I))
If L = 9 Then
RHunMln &= RMln & RTenMln & " مليون "
RTenMln = Nothing : RMln = Nothing
End If
'===============================================
End Select
End If
End If
Next
Result = RHunMln & RMln & RTenMln & RHunThus & RThus & RTenThus & RHun & ROnes & RTens
Result = Result.Remove(0, 1)
Dim RR As String
Dim II As Integer = Result.IndexOf("*")
If II >= 0 Then : RR = Result.Replace("*", " و")
Else : RR = Result
End If
Return RR
End Function

Private Function Get_ValuesBN_11_19_A(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 11 : S = "*أحد عشر"
Case 12 : S = "*إثنـى عشر"
Case 13 : S = "*ثلاثة عشر"
Case 14 : S = "*أربعة عشر"
Case 15 : S = "*خمسة عشر"
Case 16 : S = "*ستة عشر"
Case 17 : S = "*سبعة عشر"
Case 18 : S = "*ثمانية عشر"
Case 19 : S = "*تسعة عشر"
End Select
Return S
'=============================================
End Function

Private Function Get_Ones_A(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*واحد"
Case 2 : S = "*إثنـين"
Case 3 : S = "*ثلاثة"
Case 4 : S = "*أربعة"
Case 5 : S = "*خمسة"
Case 6 : S = "*ستة"
Case 7 : S = "*سبعة"
Case 8 : S = "*ثمانية"
Case 9 : S = "*تسعة"
End Select
Return S
'===============================================
End Function

Private Function Get_Tens_A(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*عشره"
Case 2 : S = "*عشرون"
Case 3 : S = "*ثلاثون"
Case 4 : S = "*أربعون"
Case 5 : S = "*خمسون"
Case 6 : S = "*ستون"
Case 7 : S = "*سبعون"
Case 8 : S = "*ثمانون"
Case 9 : S = "*تسعون"
End Select
Return S
'===============================================
End Function

Private Function Get_Hundreds_A(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*مائه"
Case 2 : S = "*مائتان"
Case 3 : S = "*ثلاثمائه"
Case 4 : S = "*أربعمائه"
Case 5 : S = "*خمسائه"
Case 6 : S = "*ستمائه"
Case 7 : S = "*سبعمائه"
Case 8 : S = "*ثمانمائه"
Case 9 : S = "*تسعمائه"
End Select
Return S
'===============================================
End Function

Private Function Get_Thousands_A(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*ألف"
Case 2 : S = "*الفان"
Case 3 : S = "*ثلاثة آلاف"
Case 4 : S = "*أربعة آلاف"
Case 5 : S = "*خمسة آلاف"
Case 6 : S = "*ستة آلاف"
Case 7 : S = "*سبعة آلاف"
Case 8 : S = "*ثمانية آلاف"
Case 9 : S = "*تسعة آلاف"
End Select
Return S
'===============================================
End Function
'============================================================================
'============================================================================
'============================================================================
'============================================================================

Public Function ConvertToEnglish(ByVal Str As String)
Dim IntStr As String = "" : Dim Frac As String = ""
Dim Result As String = ""
Dim L As Integer = Str.Length ' To Get The Length Of The Original Text
Dim M As Integer = Str.IndexOf(".") ' To Get The location Of Decimal Sign
If M > 0 Then
IntStr = Str.Remove(M, L - M) 'To Get Number Without Fractions
Frac = Str.Remove(0, M + 1) 'To Get Numbre of Fractions
ElseIf M = 0 Then : Frac = Str.Remove(0, M + 1)
ElseIf M < 0 Then : IntStr = Str : End If
'===============================
If IntStr <> Nothing Then IntStr = Get_IntStr_E(IntStr)
If Frac <> Nothing Then Frac = Get_IntStr_E(Frac)
If IntStr <> Nothing Then Result = "Only " & IntStr & " Riyals "
If Frac <> Nothing Then Result &= ", " & Frac & " Halalah "
'===============================
Return Result
End Function

Private Function Get_IntStr_E(ByRef S As String) As String
Dim Result As String
'=============================================
'Chek If S >= 11 And <= 19
If Val(S) >= 11 And Val(S) <= 19 Then
S = Get_ValuesBN_11_19_E(S)
S = S.Remove(0, 1) : Return S : Exit Function
End If
'===============================================
Dim I As Integer
Dim ROnes As String = "" : Dim RTens As String = "" : Dim RHun As String = ""
Dim RThus As String = "" : Dim RTenThus As String = "" : Dim RHunThus As String = ""
Dim RMln As String = "" : Dim RTenMln As String = "" : Dim RHunMln As String = ""
Dim SSS As String = "" : Dim J As Integer

Dim L As Integer = S.Length
For I = S.Length - 1 To 0 Step -1
If Val(S.Chars(I)) > 0 Then
Select Case I
'===============================================
Case L - 1 : ROnes = Get_Ones_E(S.Chars(I))
'===============================================
Case L - 2
For J = 0 To 7
If L = J + 2 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTens = Get_ValuesBN_11_19_E(SSS) : ROnes = Nothing
Else : RTens = Get_Tens_E(S.Chars(I)) : End If
'===============================================
Case L - 3 : RHun = Get_Hundreds_E(S.Chars(I))
'===============================================
Case L - 4 : RThus = Get_Thousands_E(S.Chars(I))
'===============================================
End Select
If L > 4 Then
Select Case I
'===============================================
Case L - 4 : RThus = Get_Ones_E(S.Chars(I))
RThus &= " Thousand "
'===============================================
Case L - 5
For J = 0 To 4
If L = J + 5 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTenThus = Get_ValuesBN_11_19_E(SSS) : RThus = Nothing
Else : RTenThus = Get_Tens_E(S.Chars(I)) : End If
If RThus = Nothing Then RTenThus &= " Thousand "
'===============================================
Case L - 6 : RHunThus = Get_Hundreds_E(S.Chars(I))
If (RTenThus = Nothing) And (RThus = Nothing) Then RHunThus &= " Thousand "
'===============================================
Case L - 7
If L = 7 Then : RMln = Get_Ones_E(S.Chars(I))
Else : RMln = Get_Ones_E(S.Chars(I)) : End If
RMln &= " Million "
'===============================================
Case L - 8
For J = 0 To 2
If L = J + 8 Then SSS = S.Substring(J, 2)
Next
If Val(SSS) >= 11 And Val(SSS) <= 19 Then
RTenMln = Get_ValuesBN_11_19_E(SSS) : RMln = Nothing
Else : RTenMln = Get_Tens_E(S.Chars(I)) : End If

If (RMln = Nothing) Then RTenMln &= " Million "
'===============================================
Case L - 9 : RHunMln = Get_Hundreds_E(S.Chars(I))
If L = 9 Then
If (RMln = Nothing) And (RTenMln = Nothing) Then RHunMln &= " Million "
End If
'===============================================
End Select
End If
End If
Next
Result = RHunMln & RTenMln & RMln & RHunThus & RTenThus & RThus & RHun & RTens & ROnes
Result = Result.Remove(0, 1)
Dim RR As String
Dim II As Integer = Result.IndexOf("*")
If II >= 0 Then : RR = Result.Replace("*", " ")
Else : RR = Result
End If
Return RR
End Function

Private Function Get_ValuesBN_11_19_E(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 11 : S = "*Eleven"
Case 12 : S = "*Twelve"
Case 13 : S = "*Therteen"
Case 14 : S = "*Fourteen"
Case 15 : S = "*Fifteen"
Case 16 : S = "*Sixteen"
Case 17 : S = "*Seventeen"
Case 18 : S = "*Eighteen"
Case 19 : S = "*Nineteen"
End Select
Return S
'=============================================
End Function

Private Function Get_Ones_E(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*One"
Case 2 : S = "*Two"
Case 3 : S = "*Three"
Case 4 : S = "*Four"
Case 5 : S = "*Five"
Case 6 : S = "*Six"
Case 7 : S = "*Seven"
Case 8 : S = "*Eight"
Case 9 : S = "*Nine"
End Select
Return S
'===============================================
End Function

Private Function Get_Tens_E(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*Ten"
Case 2 : S = "*Twenty"
Case 3 : S = "*Thirty"
Case 4 : S = "*Fourty"
Case 5 : S = "*Fifty"
Case 6 : S = "*Sixty"
Case 7 : S = "*Seventy"
Case 8 : S = "*Eighty"
Case 9 : S = "*Ninety"
End Select
Return S
'===============================================
End Function

Private Function Get_Hundreds_E(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*One Hundred"
Case 2 : S = "*Two Hundred"
Case 3 : S = "*Three Hundred"
Case 4 : S = "*Four Hundred"
Case 5 : S = "*Five Hundred"
Case 6 : S = "*Six Hundred"
Case 7 : S = "*Seven Hundred"
Case 8 : S = "*Eight Hundred"
Case 9 : S = "*Nine Hundred"
End Select
Return S
'===============================================
End Function

Private Function Get_Thousands_E(ByVal S As String) As String
'=============================================
Select Case Val(S)
Case 1 : S = "*One Thousand"
Case 2 : S = "*Two Thousand"
Case 3 : S = "*Three Thousand"
Case 4 : S = "*Four Thousand"
Case 5 : S = "*Five Thousand"
Case 6 : S = "*Six Thousand"
Case 7 : S = "*Seven Thousand"
Case 8 : S = "*Eight Thousand"
Case 9 : S = "*Nine Thousand"
End Select
Return S
'===============================================
End Function
End Class
الرد }}}
تم الشكر بواسطة: technomedia


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  تغيير لون السجلات في كريستال ريبورت بناء على قيم معينة صالح عبدالله 4 355 16-02-24, 09:30 PM
آخر رد: صالح عبدالله
  [سؤال] مشكلة في طباعة footer تقرير كريستال ريبورت i1982 5 1,124 29-03-23, 11:30 PM
آخر رد: sanyor77
Question [سؤال] سوال في الكرستال ريبورت ali bajmmal 0 381 17-02-23, 03:34 PM
آخر رد: ali bajmmal
  دالة التفقيط داخل الكريستال ريبورت bassant 6 5,437 08-02-23, 04:26 PM
آخر رد: kezzat
  هل يوجد امكانية لعمل متغير لكل record في الكريستال ريبورت bassant 0 643 29-11-22, 12:47 PM
آخر رد: bassant
  كيفية تصميم التقرير الكريستال ريبورت للطباعة على جانبين الورقة (وش وظهر) bassant 3 930 22-11-22, 12:22 PM
آخر رد: Taha Okla
  [مشروع] حل جذري لكل من يعاني من ارسال الباركود والصورة الى الكريستال ربيورت مصمم الدوادمي 7 4,259 19-10-22, 01:53 PM
آخر رد: laroos
Photo [سؤال] مشكلة في اتصال كريستال ريبورت محمد صادق حسن 1 1,346 15-12-21, 02:41 PM
آخر رد: تركي الحلواني
  كريستال ريبورت Lathe1 0 1,216 01-10-21, 12:34 PM
آخر رد: Lathe1
  تغيير اتجاة صفحة الكريستال ريبورت aftfm 0 1,607 06-09-21, 05:34 PM
آخر رد: aftfm

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


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