Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript

[yiapap]

και άλλη μια...

Σε πολλές περιπτώσεις είναι απαραίτητη η μετατροπή ενός ποσού στην περιγραφή του, όλογράφως.

Π.χ. η μετατροπή του 123,22€ σε "Εκατόν Είκοσι Τρία Ευρώ και Είκοσι Δύο Λεπτά".

Γι αυτή την μετατροπή υπάρχουν αρκετοί αλγόριθμοι για τα Αγγλικά, δυστυχώς όμως στα Ελληνικά το πρόβλημα είναι πιο σύνθετο. Αυτό οφείλεται στην ύπαρξη γένους στον αριθμό. Ενώ λέμε "Εκατόν Είκοσι Τρία" (ουδέτερο), λέμε "Εκατόν Είκοσι Τρεις Χιλιάδες" (θηλυκό).

Έτσι οι ρουτίνες που αποτελούν ακριβή μετάφραση των αντίστοιχων αγγλικών είναι καταδικασμένες σε αποτυχία...

Όχι όμως και το παρακάτω Module. O μοναδικός περιορισμός του είναι ότι δεν μπορεί να διαχειριστεί ποσά της τάξης των εκατομμυρίων Ευρώ. Δηλαδή το επιτρεπόμενο εύρος είναι από -999.999,99€ έως 999.999,99€

Visual Basic, Visual Basic For Applications

Δημιουργήστε ένα νέο Module και αντιγράψτε τον παρακάτω κώδικα:

   Option Explicit
    Dim bFemale As Boolean

    Public Function SayEuro(curAmount As Double) As String
    'Pre: curAmount is a valid number between -999.999,99 and 999.999,99
    'Post: sayEuro is a string describing the numeric value
    ' Usage Example: a=SayEuro(-123.22)->a="Μείον Εκατόv Είκοσι Τρία Ευρώ και Είκοσι Δύο Λεπτά"
    ' Yiannis Papadopoulos <www.yiapap.com> 2004

    Dim sResult As String
    sResult = ""
    If curAmount < 0 Then
    sResult = "Μείον "
    curAmount = Abs(curAmount)
    End If
    sResult = sResult & Trim(SayNumber(Int(curAmount)) & "Ευρώ")
    If curAmount - Int(curAmount) > 0 Then
    sResult = Trim(sResult & " και " & SayNumber(100 * (curAmount - Int(curAmount))) & "Λεπτά")
    End If
    SayEuro = sResult
    End Function

    Private Function SayNumber(curAmount As Long) As String
    Dim sResult
    Dim lAmount As Double
    Dim tmp As Integer

    lAmount = Round(curAmount, 0)
    sResult = ""

    'Uniques & decimals
    tmp = Val(Right(Str(lAmount), 2))
    If lAmount = 0 Then
    sResult = "Μηδέν "
    Else
    If tmp < 20 Then
    sResult = sResult & IIf(sResult = "", "", " ") & IIf(bFemale, SayUniqueFemale(tmp), SayUnique(tmp)) & " "
    Else
    sResult = sResult & SayTens(tmp) & " "
    If (tmp - 10 * (tmp \ 10)) > 0 Then sResult = sResult & IIf(bFemale, SayUniqueFemale(tmp - 10 * (tmp \ 10)), SayUnique(tmp - 10 * (tmp \ 10))) & " "
    End If
    lAmount = lAmount - tmp

    'Hundreds
    tmp = Val(Right(Str(lAmount), 3))
    If tmp > 100 Or (tmp = 100 And sResult <> "") Then sResult = IIf(bFemale, SayHundredsFemale(tmp), SayHundreds(tmp)) & " " & sResult
    If tmp = 100 And sResult = "" Then sResult = "Εκατό"
    lAmount = lAmount - tmp

    'Thousands
    If lAmount >= 1000 Then sResult = SayThousands((lAmount)) & " " & sResult
    End If
    bFemale = False
    SayNumber = sResult
    End Function

    Private Function SayUnique(iNumber As Integer) As String
    Dim vardigit
    vardigit = Array("Ένα", "Δύο", "Τρία", "Τέσσερα", _
    "Πέντε", "Έξι", "Επτά", "Οκτώ", "Εννέα", "Δέκα", "Ένδεκα", _
    "Δώδεκα", "Δεκατρία", "Δεκατέσσερα", "Δεκαπέντε", "Δεκαέξι", "Δεκαεφτά", _
    "Δεκαοχτώ", "Δεκαεννιά")

    If iNumber > 0 Then SayUnique = vardigit(iNumber - 1)
    Erase vardigit
    End Function

    Private Function SayTens(iNumber As Integer) As String
    Dim vardigit
    vardigit = Array("Δέκα-Dummy", "Είκοσι", "Τριάντα", "Σαράντα", "Πενήντα", "Εξήντα", "Εβδομήντα", _
    "Ογδόντα", "Ενενήντα")
    SayTens = vardigit(iNumber \ 10 - 1)
    Erase vardigit
    End Function

    Private Function SayHundreds(iNumber As Integer) As String
    Dim vardigit
    vardigit = Array("Εκατόv", "Διακόσια", "Τριακόσια", "Τετρακόσια", "Πεντακόσια", _
    "Εξακόσια", "Επτακόσια", "Οκτακόσια", "Εννιακόσια")
    SayHundreds = vardigit(iNumber \ 100 - 1)
    Erase vardigit
    End Function

    Private Function SayThousands(iNumber As Long) As String
    bFemale = True
    SayThousands = IIf(iNumber = 1000, "Χίλια", SayNumber(iNumber \ 1000) & "Χιλιάδες")
    End Function

    Private Function SayUniqueFemale(iNumber As Integer) As String
    Dim vardigit
    vardigit = Array("Μια", "Δύο", "Τρεις", "Τέσσερις", _
    "Πέντε", "Έξι", "Επτά", "Οκτώ", "Εννέα", "Δέκα", "Ένδεκα", _
    "Δώδεκα", "Δεκατρείς", "Δεκατέσσερεις", "Δεκαπέντε", "Δεκαέξι", "Δεκαεφτά", _
    "Δεκαοχτώ", "Δεκαεννιά")

    If iNumber > 0 Then SayUniqueFemale = vardigit(iNumber - 1)
    Erase vardigit
    End Function

    Private Function SayHundredsFemale(iNumber As Integer) As String
    Dim vardigit
    vardigit = Array("Εκατόv", "Διακόσιες", "Τριακόσιες", "Τετρακόσιες", "Πεντακόσιες", _
    "Εξακόσιες", "Επτακόσιες", "Οκτακόσιες", "Εννιακόσιες")
    SayHundredsFemale = vardigit(iNumber \ 100 - 1)
    Erase vardigit
    End Function

ASP Script (VBScript)

Αντιγράψτε τον παρακάτω κώδικα σε οποιοδήποτε σημείο της ASP σελίδας σας (συνίσταται η κορυφή)

    <%
    Dim bFemale

    Function SayEuro(curAmount)
    'Pre: curAmount is a valid number between -999.999,99 and 999.999,99
    'Post: sayEuro is a string describing the numeric value
    ' Usage Example: a=SayEuro(-123.22)->a="Μείον Εκατόv Είκοσι Τρία Ευρώ και Είκοσι Δύο Λεπτά"
    ' Yiannis Papadopoulos <www.yiapap.com> 2004

    Dim sResult
    sResult = ""
    If curAmount < 0 Then
    sResult = "Μείον "
    curAmount = Abs(curAmount)
    End If
    sResult = sResult & Trim(SayNumber(Int(curAmount)) & "Ευρώ")
    If curAmount - Int(curAmount) > 0 Then
    sResult = Trim(sResult & " και " & SayNumber(100 * (curAmount - Int(curAmount))) & "Λεπτά")
    End If
    SayEuro = sResult
    End Function

    Private Function SayNumber(curAmount)
    Dim sResult
    Dim lAmount
    Dim tmp

    lAmount = Round(curAmount, 0)
    sResult = ""

    'Uniques & decimals
    tmp = csng(Right(cStr(lAmount), 2))
    If lAmount = 0 Then
    sResult = "Μηδέν "
    Else
    If tmp < 20 Then
    if rsResult="" then sResult=sResult & " "
    if bFemale then
    sResult=sResult & SayUniqueFemale(tmp)
    else
    sResult=sResult & SayUnique(tmp)
    end if
    sResult=sResult & " "
    Else
    sResult = sResult & SayTens(tmp) & " "
    If (tmp - 10 * (tmp \ 10)) > 0 Then
    if bFemale then
    sREsult=sResult & SayUniqueFemale(tmp - 10 * (tmp \ 10))
    else
    sResult=sResult & SayUnique(tmp - 10 * (tmp \ 10))
    end if
    sResult = sResult & " "
    End If
    end if
    lAmount = lAmount - tmp

    'Hundreds
    tmp = csng(Right(cStr(lAmount), 3))
    If tmp > 100 Or (tmp = 100 And sResult <> "") Then
    if bFemale then
    sResult= SayHundredsFemale(tmp) & " " & sResult
    else
    sResult= SayHundreds(tmp) & " " & sResult
    end if
    end if
    If tmp = 100 And sResult = "" Then sResult = "Εκατό"
    lAmount = lAmount - tmp

    'Thousands
    If lAmount >= 1000 Then sResult = SayThousands((lAmount)) & " " & sResult
    End If
    bFemale = False
    SayNumber = sResult
    End Function

    Function SayUnique(iNumber)
    Dim vardigit
    vardigit = Array("Ένα", "Δύο", "Τρία", "Τέσσερα", _
    "Πέντε", "Έξι", "Επτά", "Οκτώ", "Εννέα", "Δέκα", "Ένδεκα", _
    "Δώδεκα", "Δεκατρία", "Δεκατέσσερα", "Δεκαπέντε", "Δεκαέξι", "Δεκαεφτά", _
    "Δεκαοχτώ", "Δεκαεννιά")

    If iNumber > 0 Then SayUnique = vardigit(iNumber - 1)
    Erase vardigit
    End Function

    Function SayTens(iNumber)
    Dim vardigit
    vardigit = Array("Δέκα-Dummy", "Είκοσι", "Τριάντα", "Σαράντα", "Πενήντα", "Εξήντα", "Εβδομήντα", _
    "Ογδόντα", "Ενενήντα")
    SayTens = vardigit(iNumber \ 10 - 1)
    Erase vardigit
    End Function

    Function SayHundreds(iNumber)
    Dim vardigit
    vardigit = Array("Εκατόv", "Διακόσια", "Τριακόσια", "Τετρακόσια", "Πεντακόσια", _
    "Εξακόσια", "Επτακόσια", "Οκτακόσια", "Εννιακόσια")
    SayHundreds = vardigit(iNumber \ 100 - 1)
    Erase vardigit
    End Function

    Function SayThousands(iNumber)
    bFemale = True
    if iNumber = 1000 then
    SayTHousands="Χίλια"
    else
    SayThousands= SayNumber(iNumber \ 1000) & "Χιλιάδες"
    end if
    End Function

    Function SayUniqueFemale(iNumber)
    Dim vardigit
    vardigit = Array("Μια", "Δύο", "Τρεις", "Τέσσερις", _
    "Πέντε", "Έξι", "Επτά", "Οκτώ", "Εννέα", "Δέκα", "Ένδεκα", _
    "Δώδεκα", "Δεκατρείς", "Δεκατέσσερεις", "Δεκαπέντε", "Δεκαέξι", "Δεκαεφτά", _
    "Δεκαοχτώ", "Δεκαεννιά")

    If iNumber > 0 Then SayUniqueFemale = vardigit(iNumber - 1)
    Erase vardigit
    End Function

    Private Function SayHundredsFemale(iNumber)
    Dim vardigit
    vardigit = Array("Εκατόv", "Διακόσιες", "Τριακόσιες", "Τετρακόσιες", "Πεντακόσιες", _
    "Εξακόσιες", "Επτακόσιες", "Οκτακόσιες", "Εννιακόσιες")
    SayHundredsFemale = vardigit(iNumber \ 100 - 1)
    Erase vardigit
    End Function
    %>

[Αραβανής Μηνάς]

αν μπορεί κάποιος να με βοηθήσει!
δουλεύω την access αυτοδίδαχτα. πολλά χρόνια τώρα,
έχω φτιάξει πολλά προγράμματα όμως δεν ξέρω να χρησιμοποιώ κώδικες.
έχω φτιάξει μία έκθεση για έκδοση τιμολογίων και θέλω τον αριθμό να τον μετατρέψω σε ολογράφως. υπάρχει πιο πάνω ένας κώδικας αλλά
δεν μπορώ να τον χρησιμοποιήσω. μπορεί κανείς να βοηθήσει; Ευχαριστώ.

[yiapap]

Χα, 10 χρόνια μετά! Πρέπει να είναι high score ξεθαψίματος νήματος.

Γιατί δεν μπορείς να τη χρησιμοποιήσεις;
Αν ο Αρ.Τιμ. είναι στη φόρμα σου σε πλαίσιο κειμένο με όνομα [Tim] τότε στη φόρμα από τη σχεδίαση προσθέτεις ένα νέο πλαίσιο κειμένου που στο Control Source (Πηγή Δεδομένων) γράφεις =SayEuro(Tim)

[kasampas]

Καλημέρα
Εάν δεν έχεις βρει λύση ακόμα στο πρόβλημά σου και σε ενδιαφέρει στείλε μου μήνυμα

[ppm1953]

... και μετά από 13 χρόνια .... πολύ καλό και χρήσιμο !!!