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

Function Horof(eNo As Double) As String
    Dim eFixed As String, eDecimal As String
    Dim sResult As String
    Dim LTZ As Boolean

    If eNo < 0 Then
        LTZ = True
        eNo = -eNo
    Else
        LTZ = False
    End If
    If (eNo < 1 And eNo > 0 And Len(CStr(eNo)) > 8) Or InStr(1, Trim(Str(eNo)), "E") > 0 Then
        If LTZ Then
            Horof = "-##########"
        Else
            Horof = "##########"
        End If
        Exit Function
    End If

    'return fixed value of given number as string
    eFixed = Fix(eNo)
    'تبدیل عدد به حروف در اکسس
    'if this number has some decimals
    If (Len(CStr(eNo)) - Len(eFixed)) Then
        'get it as a string, Example: return `125` for `12.125`
        If eFixed = 0 Then
            eDecimal = Mid(CStr(eNo), Len(eFixed) + 2)
        Else
            eDecimal = Left(Mid(CStr(eNo), Len(eFixed) + 2), 6)
        End If
        'return fixed part as text
        sResult = Horof_fix(eFixed) + " " & ChrW(1605) & ChrW(1605) & ChrW(1740) & ChrW(1586) & " "
        'if decimal section is `5` then use `äíã` Instead of `äÌ Ïåã`
        'this is optional, u can remove it if u like
        If eDecimal = 5 Then
            sResult = sResult + " " + ChrW(1606) & ChrW(1740) & ChrW(1605)
        Else
            'convert the decimal part of number to text
            sResult = sResult + " " + Horof_fix(eDecimal)
            'add extra suffix at end of string, depending to number of decimal places
            sResult = sResult + " " + Choose(Len(eDecimal), ChrW(1583) & ChrW(1607) & ChrW(1605), ChrW(1589) & ChrW(1583) & ChrW(1605), _
                ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605), ChrW(1583) & ChrW(1607) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605), _
                ChrW(1589) & ChrW(1583) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & ChrW(1605), ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606) & ChrW(1740) & ChrW(1608) & ChrW(1605)) ', _
                ....
        End If
            
    Else
        'if this number is originally an integer then convert it using normal method
        sResult = Horof_fix(eNo)
    End If
    'return the result. ;)
    Horof = sResult

    If LTZ Then Horof = " " & ChrW(1605) & ChrW(1606) & ChrW(1601) & ChrW(1740) & Horof
    If Horof = ChrW(1605) & ChrW(1606) & ChrW(1601) & ChrW(1740) & "##########" Then Horof = "##########"
    If eNo = 0 Then Horof = ChrW(1589) & ChrW(1601) & ChrW(1585)
End Function

'تبدیل عدد به حروف در اکسس
Function Horof_fix(ByVal Number As Double) As String
If Number = 0 Then
Horof_fix = ChrW(1589) & ChrW(1601) & ChrW(1585)
End If
Dim Flag As Boolean
Dim s As String
Dim I, L As Byte
Dim K(1 To 5) As Double

s = Trim(Str(Number))
L = Len(s)
If L > 15 Then
Horof_fix = "##########"
Exit Function
End If
For I = 1 To 15 - L
s = "0" & s
Next I
For I = 1 To Int((L / 3) + 0.99)
K(5 - I + 1) = Val(Mid(s, 3 * (5 - I) + 1, 3))
Next I
Flag = False
s = ""
For I = 1 To 5
If K(I) <> 0 Then
Select Case I
Case 1
s = s & Three(K(I)) & " " & ChrW(1578) & ChrW(1585) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606) & " "
Flag = True
Case 2
s = s & IIf(Flag = True, ChrW(1608), "") & Three(K(I)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1575) & ChrW(1585) & ChrW(1583) & " "
Flag = True
Case 3
s = s & IIf(Flag = True, ChrW(1608), "") & Three(K(I)) & " " & ChrW(1605) & ChrW(1740) & ChrW(1604) & ChrW(1740) & ChrW(1608) & ChrW(1606) & " "
Flag = True
Case 4
s = s & IIf(Flag = True, ChrW(1608), "") & Three(K(I)) & " " & ChrW(1607) & ChrW(1586) & ChrW(1575) & ChrW(1585) & " "
Flag = True
Case 5
s = s & IIf(Flag = True, ChrW(1608), "") & Three(K(I))
End Select
End If
Next I
Horof_fix = s
End Function

      'تبدیل عدد به حروف در اکسس Officebaz.ir
Function Three(ByVal Number As Integer) As String
Dim s As String
Dim I, L As Long
Dim h(1 To 3) As Byte
Dim Flag As Boolean
L = Len(Trim(Str(Abs(Number))))
If Number = 0 Then
Three = ""
Exit Function
End If
If Number = 100 Then
Three = ChrW(1740) & ChrW(1705) & ChrW(1589) & ChrW(1583)
Exit Function
End If

If L = 2 Then h(1) = 0
If L = 1 Then
h(1) = 0
h(2) = 0
End If

For I = 1 To L
h(3 - I + 1) = Mid(Trim(Str(Abs(Number))), L - I + 1, 1)
Next I

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

Select Case h(2)
Case 1
Select Case h(3)
Case 0
s = s & " " & ChrW(1608) & " " & ChrW(1583) & ChrW(1607)
Case 1
s = s & " " & ChrW(1608) & " " & ChrW(1740) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
Case 2
s = s & " " & ChrW(1608) & " " & ChrW(1583) & ChrW(1608) & ChrW(1575) & ChrW(1586) & ChrW(1583) & ChrW(1607)
Case 3
s = s & " " & ChrW(1608) & " " & ChrW(1587) & ChrW(1740) & ChrW(1586) & ChrW(1583) & ChrW(1607)
Case 4
s = s & " " & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585) & ChrW(1583) & ChrW(1607)
Case 5
s = s & " " & ChrW(1608) & " " & ChrW(1662) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
Case 6
s = s & " " & ChrW(1608) & " " & ChrW(1588) & ChrW(1575) & ChrW(1606) & ChrW(1586) & ChrW(1583) & ChrW(1607)
Case 7
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1583) & ChrW(1607)
Case 8
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1580) & ChrW(1583) & ChrW(1607)
Case 9
s = s & " " & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1586) & ChrW(1583) & ChrW(1607)
End Select

Case 2
s = s & " " & ChrW(1608) & " " & ChrW(1576) & ChrW(1740) & ChrW(1587) & ChrW(1578)
Case 3
s = s & " " & ChrW(1608) & " " & ChrW(1587) & ChrW(1740)
Case 4
s = s & " " & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1604)
Case 5
s = s & " " & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580) & ChrW(1575) & ChrW(1607)
Case 6
s = s & " " & ChrW(1608) & " " & ChrW(1588) & ChrW(1589) & ChrW(1578)
Case 7
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578) & ChrW(1575) & ChrW(1583)
Case 8
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578) & ChrW(1575) & ChrW(1583)
Case 9
s = s & " " & ChrW(1608) & " " & ChrW(1606) & ChrW(1608) & ChrW(1583)
End Select
'تبدیل عدد به حروف در اکسس
If h(2) <> 1 Then
Select Case h(3)
Case 1
s = s & " " & ChrW(1608) & " " & ChrW(1740) & ChrW(1705)
Case 2
s = s & " " & ChrW(1608) & " " & ChrW(1583) & ChrW(1608)
Case 3
s = s & " " & ChrW(1608) & " " & ChrW(1587) & ChrW(1607)
Case 4
s = s & " " & ChrW(1608) & " " & ChrW(1670) & ChrW(1607) & ChrW(1575) & ChrW(1585)
Case 5
s = s & " " & ChrW(1608) & " " & ChrW(1662) & ChrW(1606) & ChrW(1580)
Case 6
s = s & " " & ChrW(1608) & " " & ChrW(1588) & ChrW(1588)
Case 7
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1601) & ChrW(1578)
Case 8
s = s & " " & ChrW(1608) & " " & ChrW(1607) & ChrW(1588) & ChrW(1578)
Case 9
s = s & " " & ChrW(1608) & " " & ChrW(1606) & ChrW(1607)
End Select
End If
s = IIf(L < 3, Right(s, Len(s) - 3), s)
Three = s
End Function
        'تبدیل عدد به حروف در اکسس