'---------------------------------------' ' http://www.Exceliha.Ir '---------------------------------------' Option Explicit Private Const hezar = " هزار" Private Const melun = " ميليون " Private Const melyard = " ميليارد " Private Const va = "و" '--- Farsi Number Convertor ------------------' Public Function adad_be_harf(ByVal adad As Double) As String Dim hooroof As String Dim SS As Integer 'sadgan Dim hh As Integer 'hezargan Dim mm As Integer 'melungan Dim yy As Integer 'melyardgan Dim STRadad As String Dim LENadad As Integer STRadad = Str(Val(Str(adad))) LENadad = Len(STRadad) Select Case adad Case Is = 0 hooroof = "صفر" Case 1 To 999 hooroof = Adad_Heji(adad) + " ريال " Case 1000 To 999999 If (adad Mod 1000 = 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + " ريال " If (adad Mod 1000 <> 0) Then hooroof = Adad_Heji(Int(adad / 1000)) + hezar + va + (Adad_Heji(adad Mod 1000)) + " ريال " Case 1000000 To 999999999 SS = Val(Right$(STRadad, 3)) hh = Val(Mid$(STRadad, LENadad - 5, 3)) mm = Val(Left$(STRadad, LENadad - 6)) If (SS = 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + " ريال " If (SS = 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + " ريال " If (SS <> 0 And hh = 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(SS) + " ريال " If (SS <> 0 And hh <> 0) Then hooroof = Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS) + " ريال " Case 1000000000 To 999999999999# SS = Val(Right$(STRadad, 3)) hh = Val(Mid$(STRadad, LENadad - 5, 3)) mm = Val(Mid$(STRadad, LENadad - 8, 3)) yy = Val(Left$(STRadad, LENadad - 9)) If (SS = 0 And hh = 0 And mm = 0) Then hooroof = Adad_Heji(yy) + melyard + " ريال " If (SS = 0 And hh = 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + " ريال " If (SS = 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + " ريال " If (SS <> 0 And hh <> 0 And mm <> 0) Then hooroof = Adad_Heji(yy) + melyard + va + Adad_Heji(mm) + melun + va + Adad_Heji(hh) + hezar + va + Adad_Heji(SS) + " ريال " Case Is > 999999999999# hooroof = "عدد وارد شده خارج از محدوده مي باشد " End Select adad_be_harf = hooroof End Function Private Function Adad_Heji(ByVal adad As Integer) As String Dim yekan As Byte Dim dahgan As Byte Dim sadgan As Byte Dim behooroof As String Dim heji(19) As String Dim heji_dahgan(9) As String Dim heji_sadgan(9) As String '------------------------------- heji(1) = "يك": heji(2) = "دو": heji(3) = "سه": heji(4) = "چهار": heji(5) = "پنج" heji(6) = "شش": heji(7) = "هفت": heji(8) = "هشت": heji(9) = "نه": heji(10) = "ده" heji(11) = "يازده": heji(12) = "دوازده": heji(13) = "سيزده": heji(14) = "چهارده": heji(15) = "پانزده" heji(16) = "شانزده": heji(17) = "هفده": heji(18) = "هيجده": heji(19) = "نوزده" '------------------------------- heji_dahgan(1) = "ده" heji_dahgan(2) = "بيست " heji_dahgan(3) = "سي ": heji_dahgan(4) = "چهل ": heji_dahgan(5) = " پنجاه" heji_dahgan(6) = "شصت ": heji_dahgan(7) = "هفتاد": heji_dahgan(8) = "هشتاد" heji_dahgan(9) = "نود" '------------------------ heji_sadgan(1) = "يكصد": heji_sadgan(2) = "دويست": heji_sadgan(3) = "سيصد" heji_sadgan(4) = "چهارصد": heji_sadgan(5) = "پانصد": heji_sadgan(6) = "ششصد" heji_sadgan(7) = "هفتصد": heji_sadgan(8) = "هشتصد": heji_sadgan(9) = "نهصد" '------------------------------------------------------------------------------------------------------------ yekan = adad Mod 10 dahgan = adad Mod 100 sadgan = Int(adad / 100) '------------------------------------------------------------------------------------------------------------ If dahgan < 20 Then If (sadgan = 0) Then behooroof = heji(dahgan) If (sadgan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji(dahgan) If (yekan = 0 And dahgan = 0) Then behooroof = heji_sadgan(sadgan) Else dahgan = (adad Mod 100) - yekan If (sadgan = 0 And yekan = 0) Then behooroof = heji_dahgan(dahgan / 10) If (sadgan = 0 And yekan <> 0) Then behooroof = heji_dahgan(dahgan / 10) + va + heji(yekan) If (sadgan <> 0 And yekan = 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) If (sadgan <> 0 And yekan <> 0) Then behooroof = heji_sadgan(sadgan) + va + heji_dahgan(dahgan / 10) + va + heji(yekan) End If Adad_Heji = behooroof End Function Private Function change_mony(ByVal Pol As Currency) As String Dim P As String, p1 As String Dim P2 As String, P3 As String Dim P4 As String, Sk As String Dim L As Byte If Pol > 0 Then P = Str(Pol) Sk = Right(Trim(P), 3) p1 = harf(Val(Trim(Sk))) p1 = Trim(p1) & " ريال" If Len(Trim(P)) > 3 Then Sk = Right(Trim(P), 6) L = Len(Trim(Sk)) Sk = Left(Trim(Sk), (L - 3)) P2 = harf(Val(Trim(Sk))) P2 = Trim(P2) & " هزار و" End If If Len(Trim(P)) > 6 Then Sk = Right(Trim(P), 9) L = Len(Trim(Sk)) Sk = Left(Trim(Sk), (L - 6)) P3 = harf(Val(Trim(Sk))) P3 = Trim(P3) & " ميليون و" End If If Len(Trim(P)) = 10 Then Sk = Left(Trim(P), 1) P4 = harf(Val(Trim(Sk))) P4 = Trim(P4) & " ميليارد و" End If change_mony = Trim(P4) & Trim(P3) & Trim(P2) & Trim(p1) End If End Function Private Function harf(mony2 As Long) As String Dim S As String, S1 As String Dim s2 As String, s3 As String S = Trim(Str(mony2)) If Len(Trim(Str(mony2))) = 1 Then S = "00" & Trim(Str(mony2)) If Len(Trim(Str(mony2))) = 2 Then S = "0" & Trim(Str(mony2)) Select Case Left(Trim(S), 1) Case 0 S1 = "" Case 1 S1 = "يكصد " Case 2 S1 = "دويست " Case 3 S1 = "سيصد" Case 4 S1 = "چهارصد" Case 5 S1 = "پانصد" Case 6 S1 = "ششصد" Case 7 S1 = "هفتصد" Case 8 S1 = "هشتصد" Case 9 S1 = "نهصد" End Select Select Case Mid(Trim(S), 2, 1) Case 0 s2 = "" Case 1 Select Case Right(Trim(S), 1) Case 0 s2 = "ده" Case 1 s2 = "يازده" Case 2 s2 = "دوازده" Case 3 s2 = "سيزده" Case 4 s2 = "چهارده" Case 5 s2 = "پانزده" Case 6 s2 = "شانزده" Case 7 S1 = "هفده" Case 8 S1 = "هجده" Case 9 S1 = "نوزده" End Select Case 2 s2 = "بيست " Case 3 s2 = "سي " Case 4 s2 = " چهل" Case 5 s2 = " پنجاه" Case 6 s2 = "شصت " Case 7 s2 = "هفتاد" Case 8 s2 = "هشتاد" Case 9 s2 = "نود" End Select If Mid(Trim(S), 2, 1) <> 1 Then Select Case Right(Trim(S), 1) Case 0 s3 = "" Case 1 s3 = "يك" Case 2 s3 = "دو" Case 3 s3 = "سه" Case 4 s3 = "چهار" Case 5 s3 = "پنج" Case 6 s3 = "شش" Case 7 s3 = "هفت" Case 8 s3 = "هشت" Case 9 s3 = "نه" End Select End If If Trim(S1) <> "" Then S1 = S1 & " و" If Trim(s2) <> "" Then s2 = s2 & " و" If Trim(s3) <> "" Then s3 = s3 & " و" S = S1 & s2 & s3 If Trim(S) <> "" Then harf = Left(Trim(S), (Len(Trim(S)) - 1)) Else harf = "" End Function