Login Form
IPv6 Ready
Εμφάνιση 1-4 από 4
  1. #1
    Εγγραφή
    20-03-2003
    Περιοχή
    Στη μόνη πόλη που γράφεται με 2 'σ' και προφέρεται με 2 'λ'
    Ηλικία
    46
    Μηνύματα
    21.404
    Downloads
    25
    Uploads
    2
    Τύπος
    ADSL2+
    Ταχύτητα
    11000/1023
    ISP
    ΟΤΕ Conn-x
    DSLAM
    ΟΤΕ - ΡΟΣΤΑΝ
    Router
    Netgear DGN2000
    SNR / Attn
    4(dB) / 30.5(dB)
    Path Level
    Fastpath
    και άλλη μια...

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

    Π.χ. η μετατροπή του 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
        %>

  2. #2
    Εγγραφή
    28-09-2015
    Ηλικία
    57
    Μηνύματα
    1
    Downloads
    0
    Uploads
    0
    ISP
    ΟΤΕ Conn-x
    αν μπορεί κάποιος να με βοηθήσει!
    δουλεύω την access αυτοδίδαχτα. πολλά χρόνια τώρα,
    έχω φτιάξει πολλά προγράμματα όμως δεν ξέρω να χρησιμοποιώ κώδικες.
    έχω φτιάξει μία έκθεση για έκδοση τιμολογίων και θέλω τον αριθμό να τον μετατρέψω σε ολογράφως. υπάρχει πιο πάνω ένας κώδικας αλλά
    δεν μπορώ να τον χρησιμοποιήσω. μπορεί κανείς να βοηθήσει; Ευχαριστώ.

  3. #3
    Εγγραφή
    20-03-2003
    Περιοχή
    Στη μόνη πόλη που γράφεται με 2 'σ' και προφέρεται με 2 'λ'
    Ηλικία
    46
    Μηνύματα
    21.404
    Downloads
    25
    Uploads
    2
    Τύπος
    ADSL2+
    Ταχύτητα
    11000/1023
    ISP
    ΟΤΕ Conn-x
    DSLAM
    ΟΤΕ - ΡΟΣΤΑΝ
    Router
    Netgear DGN2000
    SNR / Attn
    4(dB) / 30.5(dB)
    Path Level
    Fastpath
    Χα, 10 χρόνια μετά! Πρέπει να είναι high score ξεθαψίματος νήματος.

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

  4. #4
    Εγγραφή
    23-11-2011
    Μηνύματα
    27
    Downloads
    0
    Uploads
    0
    ISP
    Conn-x OTE
    Καλημέρα
    Εάν δεν έχεις βρει λύση ακόμα στο πρόβλημά σου και σε ενδιαφέρει στείλε μου μήνυμα

Παρόμοια Θέματα

  1. Merge Cells στο Excel Χρησιμοποιόντας ASP - VBScript
    Από n_agrios στο φόρουμ Προγραμματισμός και γλώσσες προγραμματισμού
    Μηνύματα: 1
    Τελευταίο Μήνυμα: 14-02-08, 14:23
  2. [3/5] ASP Ziyaretci Defteri "mesaj_formu.asp" Script Insertion
    Από ADSLgr στο φόρουμ Ενημερώσεις ασφαλείας και νέων εκδόσεων
    Μηνύματα: 0
    Τελευταίο Μήνυμα: 17-07-07, 16:40
  3. Tools: ASP Auditor - Identify Vulnerable ASP.NET Servers
    Από ADSLgr στο φόρουμ Ενημερώσεις ασφαλείας και νέων εκδόσεων
    Μηνύματα: 0
    Τελευταίο Μήνυμα: 02-10-06, 16:40
  4. Ρουτίνα ελέγχου ΑΦΜ (VB/VBA,ASP/VBScript)
    Από yiapap στο φόρουμ Προγραμματισμός και γλώσσες προγραμματισμού
    Μηνύματα: 0
    Τελευταίο Μήνυμα: 28-04-05, 12:17

Tags για αυτό το Θέμα

Bookmarks

Bookmarks

Δικαιώματα - Επιλογές

  • Δεν μπορείτε να δημοσιεύσετε νέα θέματα
  • Δεν μπορείτε να δημοσιεύσετε νέα μηνύματα
  • Δεν μπορείτε να αναρτήσετε συνημμένα
  • Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας
  •  
  • Τα BB code είναι σε λειτουργία
  • Τα Smilies είναι σε λειτουργία
  • Το [IMG] είναι σε λειτουργία
  • Το [VIDEO] είναι σε λειτουργία
  • Το HTML είναι εκτός λειτουργίας