και άλλη μια...
Σε πολλές περιπτώσεις είναι απαραίτητη η μετατροπή ενός ποσού στην περιγραφή του, όλογράφως.
Π.χ. η μετατροπή του 123,22€ σε "Εκατόν Είκοσι Τρία Ευρώ και Είκοσι Δύο Λεπτά".
Γι αυτή την μετατροπή υπάρχουν αρκετοί αλγόριθμοι για τα Αγγλικά, δυστυχώς όμως στα Ελληνικά το πρόβλημα είναι πιο σύνθετο. Αυτό οφείλεται στην ύπαρξη γένους στον αριθμό. Ενώ λέμε "Εκατόν Είκοσι Τρία" (ουδέτερο), λέμε "Εκατόν Είκοσι Τρεις Χιλιάδες" (θηλυκό).
Έτσι οι ρουτίνες που αποτελούν ακριβή μετάφραση των αντίστοιχων αγγλικών είναι καταδικασμένες σε αποτυχία...
Όχι όμως και το παρακάτω Module. O μοναδικός περιορισμός του είναι ότι δεν μπορεί να διαχειριστεί ποσά της τάξης των εκατομμυρίων Ευρώ. Δηλαδή το επιτρεπόμενο εύρος είναι από -999.999,99€ έως 999.999,99€
Visual Basic, Visual Basic For Applications
Δημιουργήστε ένα νέο Module και αντιγράψτε τον παρακάτω κώδικα:
ASP Script (VBScript)Κώδικας: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 σελίδας σας (συνίσταται η κορυφή)
Κώδικας:<% 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 %>
Εμφάνιση 1-5 από 5
-
28-04-05, 13:22 Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript #1
-
28-09-15, 18:01 Απάντηση: Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript #2
αν μπορεί κάποιος να με βοηθήσει!
δουλεύω την access αυτοδίδαχτα. πολλά χρόνια τώρα,
έχω φτιάξει πολλά προγράμματα όμως δεν ξέρω να χρησιμοποιώ κώδικες.
έχω φτιάξει μία έκθεση για έκδοση τιμολογίων και θέλω τον αριθμό να τον μετατρέψω σε ολογράφως. υπάρχει πιο πάνω ένας κώδικας αλλά
δεν μπορώ να τον χρησιμοποιήσω. μπορεί κανείς να βοηθήσει; Ευχαριστώ.
-
28-09-15, 18:14 Απάντηση: Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript #3
Χα, 10 χρόνια μετά! Πρέπει να είναι high score ξεθαψίματος νήματος.
Γιατί δεν μπορείς να τη χρησιμοποιήσεις;
Αν ο Αρ.Τιμ. είναι στη φόρμα σου σε πλαίσιο κειμένο με όνομα [Tim] τότε στη φόρμα από τη σχεδίαση προσθέτεις ένα νέο πλαίσιο κειμένου που στο Control Source (Πηγή Δεδομένων) γράφεις =SayEuro(Tim)Όσο πιο βαθιά βάζουν το χέρι οι εταίροι στις τσέπες μας, τόσο πιο κοντά φθάνουν στα @@ μας
-
14-04-16, 11:03 Απάντηση: Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript #4
Καλημέρα
Εάν δεν έχεις βρει λύση ακόμα στο πρόβλημά σου και σε ενδιαφέρει στείλε μου μήνυμα
-
03-09-18, 21:49 Απάντηση: Μετατροπή ποσού (αριθμού) σε λέξεις (ολογράφως) VB/VBA ASP/VBScript #5
... και μετά από 13 χρόνια .... πολύ καλό και χρήσιμο !!!
Παρόμοια Θέματα
-
Merge Cells στο Excel Χρησιμοποιόντας ASP - VBScript
Από n_agrios στο φόρουμ Προγραμματισμός και γλώσσες προγραμματισμούΜηνύματα: 1Τελευταίο Μήνυμα: 14-02-08, 15:23 -
Ρουτίνα ελέγχου ΑΦΜ (VB/VBA,ASP/VBScript)
Από yiapap στο φόρουμ Προγραμματισμός και γλώσσες προγραμματισμούΜηνύματα: 0Τελευταίο Μήνυμα: 28-04-05, 13:17
Bookmarks