[Συναρτήσεις] Μεταγραφή των Ελληνικών χαρακτήρων σε Λατινικούς σύμφωνα με το πρότυπο ΕΛΟΤ 743

[Tasos]

Δημιουργός: Τάσος Φιλοξενίδης (έτος 2025)

Περιβάλλον: Excel 2003 - Excel 365


Η μεταγραφή των ελληνικών χαρακτήρων σε λατινικούς είναι ένα απαραίτητο εργαλείο για πολλές εφαρμογές, όπως:

• διεθνείς φόρμες και έγγραφα
• αναζητήσεις σε βάσεις δεδομένων
• δημιουργία URL ή αναγνωριστικών
• εισαγωγή στοιχείων σε συστήματα που δεν υποστηρίζουν ελληνικά.

Η μεταγραφή βάσει του προτύπου ΕΛΟΤ 743 διασφαλίζει συμβατότητα, αναγνωσιμότητα και συνέπεια στη χρήση των ελληνικών χαρακτήρων με λατινικά στοιχεία.

Τι κάνει ο κώδικας

Παρακάτω παραθέτω μία πλήρη υλοποίηση σε VBA (Visual Basic for Applications), η οποία:

• Υποστηρίζει μονούς χαρακτήρες αλλά και ειδικούς συνδυασμούς όπως αυ, ευ, ου, μπ, ντ, τσ, γκ, κ.λπ.
• Εντοπίζει τη φωνητική αξία ανάλογα με τα συμφραζόμενα.
• Διατηρεί τη σωστή κεφαλαιοποίηση του αρχικού κειμένου (όλα κεφαλαία, πεζά, ή μικτή μορφή).
• Περιλαμβάνει έκδοση (GreekToLatinEX) που χρησιμοποιεί μόνο Unicode χαρακτήρες (ChrW), ώστε να λειτουργεί σε υπολογιστές χωρίς ελληνικές τοπικές ρυθμίσεις (π.χ. servers ή αγγλικά Windows).

Πώς να τον χρησιμοποιήσετε

Μπορείτε να καλέσετε τη συνάρτηση: Debug.Print GreekToLatin("Καλημέρα σας!")

ή να την ενσωματώσετε σε φόρμα Excel / Access για μεταγραφή μαζικών δεδομένων.

Ο πλήρης κώδικας ακολουθεί με επεξηγηματικά σχόλια για κάθε λειτουργία.

Option Explicit ' Εξαναγκάζει τη δήλωση μεταβλητών
' Συνάρτηση: GreekToLatin
' Περιγραφή: Μετατρέπει ελληνικό κείμενο (σε χαρακτήρες Unicode) σε λατινικό.
' Χειρίζεται διφθόγγους, ειδικούς συνδυασμούς και συμφωνικά συμπλέγματα.
' Επιστρέφει: Τη μεταγραφή ως λατινική αλφαβητική συμβολοσειρά.
' ==========================================
Function GreekToLatin(strText As String) As String
    Dim i As Long
    Dim output As String
    Dim ch As String, ch2 As String
    Dim grSet As String: grSet = "αάεέηήιίϊΐοόυύϋΰωώ"    ' Χαρακτήρες που θεωρούνται "φωνήεντα"
    Dim viSet As String: viSet = "αάεέηήοόβγδζλμνρ"     ' "Σύμφωνα φωνής" για τον κανόνα αυ/ευ/ηυ

    i = 1
    Do While i <= Len(strText)
        ch = Mid(strText, i, 1)
        ch2 = IIf(i < Len(strText), Mid(strText, i + 1, 1), "")
        Dim originalChunk As String: originalChunk = ch & ch2
        Dim translit As String: translit = ""

        ' Ανίχνευση ειδικών συνδυασμών
        Select Case LCase(originalChunk)
            Case "αι", "αί": translit = "ai": i = i + 2
            Case "ει", "εί": translit = "ei": i = i + 2
            Case "οι", "οί": translit = "oi": i = i + 2
            Case "ου", "ού": translit = "ou": i = i + 2
            Case "ντ": translit = "nt": i = i + 2
            Case "τσ", "τς": translit = "ts": i = i + 2
            Case "τζ": translit = "tz": i = i + 2
            Case "γγ": translit = "ng": i = i + 2
            Case "γκ": translit = "gk": i = i + 2
            Case "γχ": translit = "nch": i = i + 2
            Case "γξ": translit = "nx": i = i + 2

                ' Ειδικός χειρισμός "μπ"
            Case "μπ"
                Dim prev As String, nextChar As String
                prev = IIf(i > 1, Mid(strText, i - 1, 1), "")
                nextChar = IIf(i + 2 <= Len(strText), Mid(strText, i + 2, 1), "")
                If InStr(grSet, LCase(prev)) > 0 And InStr(grSet, LCase(nextChar)) > 0 Then
                    translit = "mp"
                Else
                    translit = "b"
                End If
                i = i + 2

                ' Ειδικός χειρισμός αυ/ευ/ηυ ανάλογα με το επόμενο σύμφωνο
            Case "αυ", "αύ", "ευ", "εύ", "ηυ", "ηύ"
                Dim nextLetter As String: nextLetter = IIf(i + 2 <= Len(strText), Mid(strText, i + 2, 1), "")
                Dim baseChar As String: baseChar = LCase(Left(originalChunk, 1))
                Dim fivi As String
                If InStr(viSet, LCase(nextLetter)) > 0 Then
                    If baseChar = "α" Then fivi = "av"
                    If baseChar = "ε" Then fivi = "ev"
                    If baseChar = "η" Then fivi = "iv"
                Else
                    If baseChar = "α" Then fivi = "af"
                    If baseChar = "ε" Then fivi = "ef"
                    If baseChar = "η" Then fivi = "if"
                End If
                translit = fivi
                i = i + 2

            Case Else
                ' Μονός χαρακτήρας
                translit = GreekCharToLatin(ch)
                originalChunk = ch
                i = i + 1
        End Select

        ' Διατήρηση κεφαλαίων/πεζών
        output = output & CetCharCase(translit, originalChunk)
    Loop

    GreekToLatin = output
End Function

' ==========================================
' Συνάρτηση: GreekCharToLatin
' Περιγραφή: Επιστρέφει τη λατινική αντιστοιχία ενός ελληνικού χαρακτήρα
' ==========================================
Function GreekCharToLatin(ch As String) As String
    Select Case LCase(ch)
        Case "α", "ά": GreekCharToLatin = "a"
        Case "β": GreekCharToLatin = "v"
        Case "γ": GreekCharToLatin = "g"
        Case "δ": GreekCharToLatin = "d"
        Case "ε", "έ": GreekCharToLatin = "e"
        Case "ζ": GreekCharToLatin = "z"
        Case "η", "ή": GreekCharToLatin = "i"
        Case "θ": GreekCharToLatin = "th"
        Case "ι", "ί", "ϊ", "ΐ": GreekCharToLatin = "i"
        Case "κ": GreekCharToLatin = "k"
        Case "λ": GreekCharToLatin = "l"
        Case "μ": GreekCharToLatin = "m"
        Case "ν": GreekCharToLatin = "n"
        Case "ξ": GreekCharToLatin = "x"
        Case "ο", "ό": GreekCharToLatin = "o"
        Case "π": GreekCharToLatin = "p"
        Case "ρ": GreekCharToLatin = "r"
        Case "σ", "ς": GreekCharToLatin = "s"
        Case "τ": GreekCharToLatin = "t"
        Case "υ", "ύ", "ϋ", "ΰ": GreekCharToLatin = "y"
        Case "φ": GreekCharToLatin = "f"
        Case "χ": GreekCharToLatin = "ch"
        Case "ψ": GreekCharToLatin = "ps"
        Case "ω", "ώ": GreekCharToLatin = "o"
        Case Else: GreekCharToLatin = ch
    End Select
End Function

' ==========================================
' Συνάρτηση: CetCharCase
' Περιγραφή: Διατηρεί την κεφαλαιοποίηση του αρχικού ελληνικού χαρακτήρα ή συνδυασμού
' ==========================================
Function CetCharCase(translit As String, original As String) As String
' Ειδική περίπτωση για τελικό σίγμα

    Select Case True
        Case original = "ς": CetCharCase = "s": Exit Function
        Case original = "ΐ", original = "ϊ": CetCharCase = "i": Exit Function
        Case original = "Ϊ": CetCharCase = "I": Exit Function
        Case original = "ΰ", original = "ϋ": CetCharCase = "y": Exit Function
        Case original = "Ϋ": CetCharCase = "Y": Exit Function
    End Select

    ' Έλεγχος κεφαλαίων/πεζών
    Dim allUpper As Boolean: allUpper = True
    Dim allLower As Boolean: allLower = True
    Dim i As Long
    For i = 1 To Len(original)
        Dim ch As String: ch = Mid(original, i, 1)
        If ch <> UCase(ch) Then allUpper = False
        If ch <> LCase(ch) Then allLower = False
    Next i

    If allUpper Then
        CetCharCase = UCase(translit)
    ElseIf Left(original, 1) = UCase(Left(original, 1)) And Mid(original, 2) = LCase(Mid(original, 2)) Then
        CetCharCase = UCase(Left(translit, 1)) & Mid(translit, 2)
    Else
        CetCharCase = LCase(translit)
    End If
End Function

Ο πλήρης κώδικας για συστήματα χωρίς ελληνικό locale (π.χ. servers, αγγλικά Windows) ακολουθεί με επεξηγηματικά σχόλια για κάθε λειτουργία.

Πώς να τον χρησιμοποιήσετε

Μπορείτε να καλέσετε τη συνάρτηση: Debug.Print GreekToLatinEX("Καλημέρα σας!")

ή να την ενσωματώσετε σε φόρμα Excel / Access για μεταγραφή μαζικών δεδομένων.

Option Explicit ' Εξαναγκάζει τη δήλωση μεταβλητών


' ==========================================
' Συνάρτηση: GreekToLatinEX
' Περιγραφή:
'   Μετατρέπει ελληνικό κείμενο Unicode σε λατινικό (transliteration),
'   χρησιμοποιώντας χαρακτήρες Unicode (ChrW) ώστε να λειτουργεί σωστά
'   σε συστήματα χωρίς ελληνικό locale (π.χ. servers, αγγλικά Windows).
'
' Επιστρέφει: Το λατινικό αντίστοιχο της ελληνικής εισόδου
' ==========================================
Function GreekToLatinEX(strText As String) As String
    Dim i As Long
    Dim output As String
    Dim ch As String, ch2 As String
    Dim grSet As String
    grSet = ChrW(945) & ChrW(940) & ChrW(949) & ChrW(941) & ChrW(951) & ChrW(942) & ChrW(953) & ChrW(943) & _
            ChrW(970) & ChrW(912) & ChrW(959) & ChrW(972) & ChrW(965) & ChrW(973) & ChrW(971) & ChrW(944) & _
            ChrW(969) & ChrW(974)
    
    Dim viSet As String
    viSet = ChrW(945) & ChrW(940) & ChrW(949) & ChrW(941) & ChrW(951) & ChrW(942) & ChrW(959) & ChrW(972) & _
            ChrW(946) & ChrW(947) & ChrW(948) & ChrW(950) & ChrW(955) & ChrW(956) & ChrW(957) & ChrW(961)

    i = 1
    Do While i <= Len(strText)
        ch = Mid(strText, i, 1)
        ch2 = IIf(i < Len(strText), Mid(strText, i + 1, 1), "")

        Dim originalChunk As String
        originalChunk = ch & ch2

        Dim translit As String
        translit = ""

        ' Ειδικοί συνδυασμοί χαρακτήρων
        Select Case LCase(originalChunk)
            Case ChrW(945) & ChrW(953), ChrW(945) & ChrW(943): translit = "ai": i = i + 2
            Case ChrW(949) & ChrW(953), ChrW(949) & ChrW(943): translit = "ei": i = i + 2
            Case ChrW(959) & ChrW(953), ChrW(959) & ChrW(943): translit = "oi": i = i + 2
            Case ChrW(959) & ChrW(965), ChrW(959) & ChrW(973): translit = "ou": i = i + 2
            Case ChrW(957) & ChrW(964): translit = "nt": i = i + 2
            Case ChrW(964) & ChrW(963), ChrW(964) & ChrW(962): translit = "ts": i = i + 2
            Case ChrW(964) & ChrW(950): translit = "tz": i = i + 2
            Case ChrW(947) & ChrW(947): translit = "ng": i = i + 2
            Case ChrW(947) & ChrW(954): translit = "gk": i = i + 2
            Case ChrW(947) & ChrW(967): translit = "nch": i = i + 2
            Case ChrW(947) & ChrW(958): translit = "nx": i = i + 2

                ' "μπ" -> "mp" ή "b" ανάλογα με συμφραζόμενα
            Case ChrW(956) & ChrW(960)
                Dim prev As String, nextChar As String
                prev = IIf(i > 1, Mid(strText, i - 1, 1), "")
                nextChar = IIf(i + 2 <= Len(strText), Mid(strText, i + 2, 1), "")
                If InStr(grSet, LCase(prev)) > 0 And InStr(grSet, LCase(nextChar)) > 0 Then
                    translit = "mp"
                Else
                    translit = "b"
                End If
                i = i + 2

                ' "αυ", "ευ", "ηυ" -> av/af, ev/ef, iv/if ανάλογα με επόμενο γράμμα
            Case ChrW(945) & ChrW(965), ChrW(945) & ChrW(973), _
                 ChrW(949) & ChrW(965), ChrW(949) & ChrW(973), _
                 ChrW(951) & ChrW(965), ChrW(951) & ChrW(973)

                Dim nextLetter As String
                nextLetter = IIf(i + 2 <= Len(strText), Mid(strText, i + 2, 1), "")
                Dim baseChar As String: baseChar = LCase(Left(originalChunk, 1))
                Dim fivi As String

                If InStr(viSet, LCase(nextLetter)) > 0 Then
                    If baseChar = ChrW(945) Then fivi = "av"
                    If baseChar = ChrW(949) Then fivi = "ev"
                    If baseChar = ChrW(951) Then fivi = "iv"
                Else
                    If baseChar = ChrW(945) Then fivi = "af"
                    If baseChar = ChrW(949) Then fivi = "ef"
                    If baseChar = ChrW(951) Then fivi = "if"
                End If
                translit = fivi
                i = i + 2

            Case Else
                ' Μονός χαρακτήρας
                translit = GreekCharToLatinEX(ch)
                originalChunk = ch
                i = i + 1
        End Select

        output = output & CetCharCaseEX(translit, originalChunk)
    Loop

    GreekToLatinEX = output
End Function

' ==========================================
' Συνάρτηση: GreekCharToLatinEX
' Περιγραφή: Επιστρέφει τη λατινική μορφή ενός ελληνικού χαρακτήρα Unicode.
' ==========================================
Function GreekCharToLatinEX(ch As String) As String
    Select Case LCase(ch)
        Case ChrW(945), ChrW(940): GreekCharToLatinEX = "a"
        Case ChrW(946): GreekCharToLatinEX = "v"
        Case ChrW(947): GreekCharToLatinEX = "g"
        Case ChrW(948): GreekCharToLatinEX = "d"
        Case ChrW(949), ChrW(941): GreekCharToLatinEX = "e"
        Case ChrW(950): GreekCharToLatinEX = "z"
        Case ChrW(951), ChrW(942): GreekCharToLatinEX = "i"
        Case ChrW(952): GreekCharToLatinEX = "th"
        Case ChrW(953), ChrW(943), ChrW(970), ChrW(912): GreekCharToLatinEX = "i"
        Case ChrW(954): GreekCharToLatinEX = "k"
        Case ChrW(955): GreekCharToLatinEX = "l"
        Case ChrW(956): GreekCharToLatinEX = "m"
        Case ChrW(957): GreekCharToLatinEX = "n"
        Case ChrW(958): GreekCharToLatinEX = "x"
        Case ChrW(959), ChrW(972): GreekCharToLatinEX = "o"
        Case ChrW(960): GreekCharToLatinEX = "p"
        Case ChrW(961): GreekCharToLatinEX = "r"
        Case ChrW(963), ChrW(962): GreekCharToLatinEX = "s"
        Case ChrW(964): GreekCharToLatinEX = "t"
        Case ChrW(965), ChrW(973), ChrW(971), ChrW(944): GreekCharToLatinEX = "y"
        Case ChrW(966): GreekCharToLatinEX = "f"
        Case ChrW(967): GreekCharToLatinEX = "ch"
        Case ChrW(968): GreekCharToLatinEX = "ps"
        Case ChrW(969), ChrW(974): GreekCharToLatinEX = "o"
        Case Else: GreekCharToLatinEX = ch
    End Select
End Function

' ==========================================
' Συνάρτηση: CetCharCaseEX
' Περιγραφή:
'   Επαναφέρει την κεφαλαιοποίηση της μεταγραμμένης λέξης (translit),
'   με βάση την ελληνική λέξη (original), χωρίς εξάρτηση από locale.
'
' Ιδανική για συστήματα χωρίς ελληνικές ρυθμίσεις (intl.cpl).
' ==========================================
Function CetCharCaseEX(translit As String, original As String) As String
' Ειδική περίπτωση για τελικό σίγμα (ς)
    If original = ChrW(962) Then
        CetCharCaseEX = "s"
        Exit Function
    End If

    Select Case True
            original = ChrW(962): CetCharCase = "s": Exit Function
        Case LCase(original) = ChrW(912), LCase(original) = ChrW(970): CetCharCase = "i": Exit Function
        Case LCase(original) = ChrW(944), LCase(original) = ChrW(971): CetCharCase = "y": Exit Function
    End Select



    ' Έλεγχος αν όλοι οι χαρακτήρες είναι κεφαλαίοι ή πεζοί
    Dim allUpper As Boolean: allUpper = True
    Dim allLower As Boolean: allLower = True
    Dim i As Long

    For i = 1 To Len(original)
        Dim ch As String: ch = Mid(original, i, 1)
        If ch <> UCase(ch) Then allUpper = False
        If ch <> LCase(ch) Then allLower = False
    Next i

    ' Εφαρμογή μορφοποίησης
    If allUpper Then
        CetCharCaseEX = UCase(translit)
    ElseIf Left(original, 1) = UCase(Left(original, 1)) And Mid(original, 2) = LCase(Mid(original, 2)) Then
        CetCharCaseEX = UCase(Left(translit, 1)) & Mid(translit, 2)
    Else
        CetCharCaseEX = LCase(translit)
    End If
End Function

Δείτε το επισυναπτόμενο αρχείο.