درخواست کد سورس تبدیل عدد به حروف (فارسی)

[pejmank]

سلام
کد vba رو میخوام برای تبدیل عدد به حروف.
(نسخه انگلیسیش رو دارم و دنبال سورس برای تبدیل عدد به حروف فارسی میگردم)

با تشکر

[Amir Ghasemiyan]

سلام
کد vba رو میخوام برای تبدیل عدد به حروف.
(نسخه انگلیسیش رو دارم و دنبال سورس برای تبدیل عدد به حروف فارسی میگردم)

با تشکر

سلام دوست عزيز
بفرماييد


Global AlphaNumeric1(0 To 19) As String
Global AlphaNumeric2(1 To 9) As String
Global AlphaNumeric3(1 To 9) As String
Function AbH(Number As String) As String


Dim IsNegative As String
Dim DotPosition As Integer
Dim IntegerSegment As String
Dim DecimalSegment As String
Dim DotTxt, DecimalTxt As String


If Val(Number) >= 0 Then IsNegative = "" Else IsNegative = ChrW(1605) & ChrW(1606) & ChrW(1601) & ChrW(1740) & " "
DotPosition = InStr(1, Number, ".")


If Not (DotPosition) = 0 Then
IntegerSegment = Left(Abs(Number), DotPosition - 1)
DecimalSegment = Left(Right(Number, Len(Number) - DotPosition), 5)

If Val(IntegerSegment) <> 0 Then DotTxt = _
" " & ChrW(1605) & ChrW(1605) & ChrW(1740) & ChrW(1586) & " " _
Else DotTxt = ""


Select Case Len(DecimalSegment)


Case 1
DecimalTxt = " " & ChrW(1583) & ChrW(1607) & ChrW(1605)
Case 2
DecimalTxt = " " & ChrW(1589) & ChrW(1583) & ChrW(1605)
Case 3
DecimalTxt = " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605)
Case 4
DecimalTxt = " " & ChrW(1583) & ChrW(1607) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605)
Case 5
DecimalTxt = " " & ChrW(1589) & ChrW(1583) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605)

End Select



AbH = IsNegative & Horof(IntegerSegment) & DotTxt & Horof(DecimalSegment) & DecimalTxt


Exit Function


End If



AbH = WorksheetFunction.Trim(IsNegative & Horof(Abs(Number)))




End Function


Sub alphaset()
Dim i%
AlphaNumeric1(0) = ChrW(1589) & ChrW(1601) & ChrW(1585)
AlphaNumeric1(1) = ChrW(1740) & ChrW(1705)
AlphaNumeric1(2) = ChrW(1583) & ChrW(1608)
AlphaNumeric1(3) = ChrW(1587) & ChrW(1607)
AlphaNumeric1(4) = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585)
AlphaNumeric1(5) = ChrW(1662) & ChrW(1606) & ChrW(1580)
AlphaNumeric1(6) = ChrW(1588) & ChrW(1588)
AlphaNumeric1(7) = ChrW(1607) & ChrW(1601) & ChrW(1578)
AlphaNumeric1(8) = ChrW(1607) & ChrW(1588) & ChrW(1578)
AlphaNumeric1(9) = ChrW(1606) & ChrW(1607)
AlphaNumeric1(10) = ChrW(1583) & ChrW(1607)
AlphaNumeric1(11) = ChrW(1740) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(12) = ChrW(1583) & ChrW(1608) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(13) = ChrW(1587) & ChrW(1740) & ChrW(1586) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(14) = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(15) = ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(16) = ChrW(1588) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(17) = ChrW(1607) & ChrW(1601) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(18) = ChrW(1607) & ChrW(1740) & ChrW(1580) & ChrW(1583) & ChrW(1607)
AlphaNumeric1(19) = ChrW(1606) & ChrW(1608) & ChrW(1586) & ChrW(1583) & ChrW(1607)




AlphaNumeric2(1) = ChrW(1583) & ChrW(1607)
AlphaNumeric2(2) = ChrW(1576) & ChrW(1740) & ChrW(1587) & ChrW(1578)
AlphaNumeric2(3) = ChrW(1587) & ChrW(1740)
AlphaNumeric2(4) = ChrW(1670) & ChrW(1607) & ChrW(1604)
AlphaNumeric2(5) = ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(1575) & ChrW(1607)
AlphaNumeric2(6) = ChrW(1588) & ChrW(1589) & ChrW(1578)
AlphaNumeric2(7) = ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1575) & ChrW(1583)
AlphaNumeric2(8) = ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1575) & ChrW(1583)
AlphaNumeric2(9) = ChrW(1606) & ChrW(1608) & ChrW(1583)

AlphaNumeric3(1) = ChrW(1740) & ChrW(1705) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(2) = ChrW(1583) & ChrW(1608) & ChrW(1740) & ChrW(1587) & ChrW(1578)
AlphaNumeric3(3) = ChrW(1587) & ChrW(1740) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(4) = ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(5) = ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(6) = ChrW(1588) & ChrW(1588) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(7) = ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(8) = ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1589) & ChrW(1583)
AlphaNumeric3(9) = ChrW(1606) & ChrW(1607) & ChrW(1589) & ChrW(1583)


End Sub




Function Horof(Number As String) As String


alphaset

Dim No As Currency, N As String

On Error GoTo Horoferror

No = CCur(Number)
N = CStr(No)

Select Case Len(N)
Case 1 To 3:
If N < 20 Then
Horof = AlphaNumeric1(N)
ElseIf N < 100 Then
If N Mod 10 = 0 Then
Horof = AlphaNumeric2(N \ 10)
Else
Horof = AlphaNumeric2(N \ 10) & " " & ChrW(1608) & " " & Horof(N Mod 10)
End If
ElseIf N < 1000 Then
If N Mod 100 = 0 Then
Horof = AlphaNumeric3(N \ 100)
Else
Horof = AlphaNumeric3(N \ 100) & " " & ChrW(1608) & " " & Horof(N Mod 100)
End If

End If
Case 4 To 6:
If (Right(N, 3)) = 0 Then
Horof = Horof(Left(N, Len(N) - 3)) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & " "
Else
Horof = Horof(Left(N, Len(N) - 3)) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & " " & ChrW(1608) & " " & Horof(Right(N, 3))
End If
Case 7 To 9:
If (Right(N, 6)) = 0 Then
Horof = Horof(Left(N, Len(N) - 6)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606) & " "
Else
Horof = Horof(Left(N, Len(N) - 6)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606) & " " & ChrW(1608) & " " & Horof(Right(N, 6))
End If
Case Else:
If (Right(N, 9)) = 0 Then
Horof = Horof(Left(N, Len(N) - 9)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1575) & ChrW(1585) & ChrW(1583) & " "
Else
Horof = Horof(Left(N, Len(N) - 9)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1575) & ChrW(1585) & ChrW(1583) & " " & ChrW(1608) & " " & Horof(Right(N, 9))
End If

End Select

Exit Function
Horoferror:
Horof = "#Error"
End Function


منبع : سايت فرساران