Μετατροπή πολυτονικού κειμένου σε μονοτονικό στο Word και στο Excel

Με τη VBA μακροεντολή From Polytonic To Monotonic  για Word ή για Excel, (τον κώδικα θα βρείτε πιο κάτω), μπορείτε να μετατρέψετε ένα κείμενο που είναι γραμμένο με πολυτονικούς χαρακτήρες σε μονοτονικούς.
Η μακροεντολή :
•Αντικαθιστά την περισπωμένη, την οξεία και την βαρεία με τον απλό τόνο.
•Αφαιρεί την υπογεγραμμένη και την προσγεγραμμένη
•Αφαιρεί τα πνεύματα ψιλή και δασεία.
•Ψάχνει σε ένα πίνακα 228 εκτός ANSI ελληνικών χαρακτήρων και τους αντικαθιστά με ισοδύναμους εντός ANSI.
Η ρουτίνα δεν παίρνει ορθογραφικές αποφάσεις, πχ ποιες μονοσύλλαβες λέξεις θα τονιστούν και ποιες όχι. Αυτό πρέπει να το κάνετε μόνος σας ή να χρησιμοποιήσετε τον ορθογράφο του Word. Στην εικόνα παρακάτω βλέπετε πως η μακροεντολή μετέτρεψε κείμενο του Αλέξανδρου Παπαδιαμάντη.

papadiamantis

Παράδειγμα μετατροπής κειμένου

Η χρήση της μακροεντολής είναι απλή. Επιλέγετε το πολυτονικό κείμενο και την τρέχετε. Το κείμενο θα μετατραπεί σε μονοτονικό. Πιο καλά δοκιμάστε σε ένα αντίγραφο του κειμένου, για να δείτε αν το αποτέλεσμα σας ικανοποιεί. Πολύ μεγάλα κείμενα, μεγαλύτερα από 10-15 σελίδες, χωρίστε τα σε μικρότερα τμήματα.
Τον κώδικα της μακροεντολής και για το Word και για το Excel θα βρείτε στο αρχείο: FromPolytonicToMonotonic.
Το ίδιο αρχείο μπορείτε να κατεβάσετε και από εδώ.

– – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – – –
Το σημείωμα αυτό αναθεωρήθηκε την 15/2/2015. Ο κώδικας έχει ξαναγραφτεί σε νέα μορφή ώστε να βελτιωθεί η ταχύτητά του. Το κείμενο του Παπαδιαμάντη πήρα από εδώ.

This entry was posted in excel, Μακροεντολές, VBA, Word and tagged , , , , . Bookmark the permalink.

12 Responses to Μετατροπή πολυτονικού κειμένου σε μονοτονικό στο Word και στο Excel

  1. Ο/Η T. Papadimitriou λέει:

    Συγχαρητήρια για τη σοβαρή αυτή εργασία. Είναι χρήσιμη για πολλούς και σε μένα.
    Ψάχνω στο διαδίκτυο για εναλλακτικές λύσεις σε εφαρμογή που ετοιμάζω σε VB6 για μετατροπή ελληνικού κειμένου σε λατινικούς χαρακτήρες σύμφωνα με το ISO 843-2 ή πρότυπο ΕΛΟΤ 743-2 (για ονόματα σε διαβατήρια, ταυτότητες, άδειες οδήγησης, τοπωνύμια κτλ).
    Η περίπτωση που αναφέρεστε πιο πάνω (μετατροπή Πολυτονικού κειμένου σε Μονοτονικό) είναι κάτι που με ενδιαφέρει. Η ταχύτητα μετατροπής όμως είναι πολύ σημαντικό θέμα. Χρησιμοποίησα τη συνάρτηση «Replace» γιατί «τρέχει» πολύ γρήγορα σε σχέση με Συναρτήσεις Χρήστη (UDF). Σε δοκιμή με περίπου 500.000 χαρακτήρες ο χρόνος εκτέλεσης είναι περίπου 1,5 δευτερόλεπτα και σε 5.000.000 χαρακτήρες 2,7 λεπτά.

    Μακροεντολή PolyToMono για WORD:
    Προσαρμόστε τη μακροεντολή σε έγγραφο του Word.
    Επιλέξτε το πολυτονικό κείμενο και τρέξτε τη μακροεντολή.

    Sub PolyToMono()
    'by TASOS PAPADIMITRIOU (Sept 2014)
    
    Dim TheString As String
    sngStart = Timer
    
    TheString = ActiveWindow.Selection
    
    If Len(ActiveWindow.Selection) <= 1 Then
    'MsgBox ("Επιλέξετε μέρος ή ολόκληρο το πολυτονικό κείμενο     ") & vbLf & ("το οποίο θέλετε να μετατρέψετε σε μονοτονικό.     "), vbInformation, "Επιλέξτε Κείμενο"
    MsgBox ("Select some or all of the POLYTONIC text     ") & vbLf & ("you want to convert to MONOTONIC.     "), vbInformation, "Select Text"
    ' "Select some or all of the POLYTONIC text" "you want to convert to MONOTONIC"
    
    End If
    
    TheString = Replace(TheString, ChrW(976), ChrW(946))
    TheString = Replace(TheString, ChrW(977), ChrW(952))
    TheString = Replace(TheString, ChrW(978), ChrW(933))
    TheString = Replace(TheString, ChrW(979), ChrW(910))
    TheString = Replace(TheString, ChrW(980), ChrW(939))
    TheString = Replace(TheString, ChrW(981), ChrW(966))
    TheString = Replace(TheString, ChrW(982), ChrW(960))
    TheString = Replace(TheString, ChrW(983), ChrW(38))
    TheString = Replace(TheString, ChrW(1008), ChrW(954))
    TheString = Replace(TheString, ChrW(1009), ChrW(961))
    TheString = Replace(TheString, ChrW(1010), ChrW(963))
    TheString = Replace(TheString, ChrW(1012), ChrW(920))
    TheString = Replace(TheString, ChrW(1013), ChrW(949))
    TheString = Replace(TheString, ChrW(7936), ChrW(945))
    TheString = Replace(TheString, ChrW(7937), ChrW(945))
    TheString = Replace(TheString, ChrW(7938), ChrW(940))
    TheString = Replace(TheString, ChrW(7939), ChrW(940))
    TheString = Replace(TheString, ChrW(7940), ChrW(940))
    TheString = Replace(TheString, ChrW(7941), ChrW(940))
    TheString = Replace(TheString, ChrW(7942), ChrW(940))
    TheString = Replace(TheString, ChrW(7943), ChrW(940))
    TheString = Replace(TheString, ChrW(7944), ChrW(913))
    TheString = Replace(TheString, ChrW(7945), ChrW(913))
    TheString = Replace(TheString, ChrW(7946), ChrW(902))
    TheString = Replace(TheString, ChrW(7947), ChrW(902))
    TheString = Replace(TheString, ChrW(7948), ChrW(902))
    TheString = Replace(TheString, ChrW(7949), ChrW(902))
    TheString = Replace(TheString, ChrW(7950), ChrW(902))
    TheString = Replace(TheString, ChrW(7951), ChrW(902))
    TheString = Replace(TheString, ChrW(7952), ChrW(949))
    TheString = Replace(TheString, ChrW(7953), ChrW(949))
    TheString = Replace(TheString, ChrW(7954), ChrW(941))
    TheString = Replace(TheString, ChrW(7955), ChrW(941))
    TheString = Replace(TheString, ChrW(7956), ChrW(941))
    TheString = Replace(TheString, ChrW(7957), ChrW(941))
    TheString = Replace(TheString, ChrW(7960), ChrW(917))
    TheString = Replace(TheString, ChrW(7961), ChrW(917))
    TheString = Replace(TheString, ChrW(7962), ChrW(904))
    TheString = Replace(TheString, ChrW(7963), ChrW(904))
    TheString = Replace(TheString, ChrW(7964), ChrW(904))
    TheString = Replace(TheString, ChrW(7965), ChrW(904))
    TheString = Replace(TheString, ChrW(7968), ChrW(951))
    TheString = Replace(TheString, ChrW(7969), ChrW(951))
    TheString = Replace(TheString, ChrW(7970), ChrW(942))
    TheString = Replace(TheString, ChrW(7971), ChrW(942))
    TheString = Replace(TheString, ChrW(7972), ChrW(942))
    TheString = Replace(TheString, ChrW(7973), ChrW(942))
    TheString = Replace(TheString, ChrW(7974), ChrW(942))
    TheString = Replace(TheString, ChrW(7975), ChrW(942))
    TheString = Replace(TheString, ChrW(7976), ChrW(919))
    TheString = Replace(TheString, ChrW(7977), ChrW(919))
    TheString = Replace(TheString, ChrW(7978), ChrW(905))
    TheString = Replace(TheString, ChrW(7979), ChrW(905))
    TheString = Replace(TheString, ChrW(7980), ChrW(905))
    TheString = Replace(TheString, ChrW(7981), ChrW(905))
    TheString = Replace(TheString, ChrW(7982), ChrW(905))
    TheString = Replace(TheString, ChrW(7983), ChrW(905))
    TheString = Replace(TheString, ChrW(7984), ChrW(953))
    TheString = Replace(TheString, ChrW(7985), ChrW(953))
    TheString = Replace(TheString, ChrW(7986), ChrW(943))
    TheString = Replace(TheString, ChrW(7987), ChrW(943))
    TheString = Replace(TheString, ChrW(7988), ChrW(943))
    TheString = Replace(TheString, ChrW(7989), ChrW(943))
    TheString = Replace(TheString, ChrW(7990), ChrW(943))
    TheString = Replace(TheString, ChrW(7991), ChrW(943))
    TheString = Replace(TheString, ChrW(7992), ChrW(921))
    TheString = Replace(TheString, ChrW(7993), ChrW(921))
    TheString = Replace(TheString, ChrW(7994), ChrW(906))
    TheString = Replace(TheString, ChrW(7995), ChrW(906))
    TheString = Replace(TheString, ChrW(7996), ChrW(906))
    TheString = Replace(TheString, ChrW(7997), ChrW(906))
    TheString = Replace(TheString, ChrW(7998), ChrW(906))
    TheString = Replace(TheString, ChrW(7999), ChrW(906))
    TheString = Replace(TheString, ChrW(8000), ChrW(959))
    TheString = Replace(TheString, ChrW(8001), ChrW(959))
    TheString = Replace(TheString, ChrW(8002), ChrW(972))
    TheString = Replace(TheString, ChrW(8003), ChrW(972))
    TheString = Replace(TheString, ChrW(8004), ChrW(972))
    TheString = Replace(TheString, ChrW(8005), ChrW(972))
    TheString = Replace(TheString, ChrW(8008), ChrW(927))
    TheString = Replace(TheString, ChrW(8009), ChrW(927))
    TheString = Replace(TheString, ChrW(8010), ChrW(908))
    TheString = Replace(TheString, ChrW(8011), ChrW(908))
    TheString = Replace(TheString, ChrW(8012), ChrW(908))
    TheString = Replace(TheString, ChrW(8013), ChrW(908))
    TheString = Replace(TheString, ChrW(8016), ChrW(965))
    TheString = Replace(TheString, ChrW(8017), ChrW(965))
    TheString = Replace(TheString, ChrW(8018), ChrW(973))
    TheString = Replace(TheString, ChrW(8019), ChrW(973))
    TheString = Replace(TheString, ChrW(8020), ChrW(973))
    TheString = Replace(TheString, ChrW(8021), ChrW(973))
    TheString = Replace(TheString, ChrW(8022), ChrW(973))
    TheString = Replace(TheString, ChrW(8023), ChrW(973))
    TheString = Replace(TheString, ChrW(8025), ChrW(933))
    TheString = Replace(TheString, ChrW(8027), ChrW(910))
    TheString = Replace(TheString, ChrW(8029), ChrW(910))
    TheString = Replace(TheString, ChrW(8031), ChrW(910))
    TheString = Replace(TheString, ChrW(8032), ChrW(969))
    TheString = Replace(TheString, ChrW(8033), ChrW(969))
    TheString = Replace(TheString, ChrW(8034), ChrW(974))
    TheString = Replace(TheString, ChrW(8035), ChrW(974))
    TheString = Replace(TheString, ChrW(8036), ChrW(974))
    TheString = Replace(TheString, ChrW(8037), ChrW(974))
    TheString = Replace(TheString, ChrW(8038), ChrW(974))
    TheString = Replace(TheString, ChrW(8039), ChrW(974))
    TheString = Replace(TheString, ChrW(8040), ChrW(937))
    TheString = Replace(TheString, ChrW(8041), ChrW(937))
    TheString = Replace(TheString, ChrW(8042), ChrW(911))
    TheString = Replace(TheString, ChrW(8043), ChrW(911))
    TheString = Replace(TheString, ChrW(8044), ChrW(911))
    TheString = Replace(TheString, ChrW(8045), ChrW(911))
    TheString = Replace(TheString, ChrW(8046), ChrW(911))
    TheString = Replace(TheString, ChrW(8047), ChrW(911))
    TheString = Replace(TheString, ChrW(8048), ChrW(940))
    TheString = Replace(TheString, ChrW(8049), ChrW(940))
    TheString = Replace(TheString, ChrW(8050), ChrW(941))
    TheString = Replace(TheString, ChrW(8051), ChrW(941))
    TheString = Replace(TheString, ChrW(8052), ChrW(942))
    TheString = Replace(TheString, ChrW(8053), ChrW(942))
    TheString = Replace(TheString, ChrW(8054), ChrW(943))
    TheString = Replace(TheString, ChrW(8055), ChrW(943))
    TheString = Replace(TheString, ChrW(8056), ChrW(972))
    TheString = Replace(TheString, ChrW(8057), ChrW(972))
    TheString = Replace(TheString, ChrW(8058), ChrW(973))
    TheString = Replace(TheString, ChrW(8059), ChrW(973))
    TheString = Replace(TheString, ChrW(8060), ChrW(974))
    TheString = Replace(TheString, ChrW(8061), ChrW(974))
    TheString = Replace(TheString, ChrW(8064), ChrW(945))
    TheString = Replace(TheString, ChrW(8065), ChrW(945))
    TheString = Replace(TheString, ChrW(8066), ChrW(940))
    TheString = Replace(TheString, ChrW(8067), ChrW(940))
    TheString = Replace(TheString, ChrW(8068), ChrW(940))
    TheString = Replace(TheString, ChrW(8069), ChrW(940))
    TheString = Replace(TheString, ChrW(8070), ChrW(940))
    TheString = Replace(TheString, ChrW(8071), ChrW(940))
    TheString = Replace(TheString, ChrW(8072), ChrW(913))
    TheString = Replace(TheString, ChrW(8073), ChrW(913))
    TheString = Replace(TheString, ChrW(8074), ChrW(902))
    TheString = Replace(TheString, ChrW(8075), ChrW(902))
    TheString = Replace(TheString, ChrW(8076), ChrW(902))
    TheString = Replace(TheString, ChrW(8077), ChrW(902))
    TheString = Replace(TheString, ChrW(8078), ChrW(902))
    TheString = Replace(TheString, ChrW(8079), ChrW(902))
    TheString = Replace(TheString, ChrW(8080), ChrW(951))
    TheString = Replace(TheString, ChrW(8081), ChrW(951))
    TheString = Replace(TheString, ChrW(8082), ChrW(942))
    TheString = Replace(TheString, ChrW(8083), ChrW(942))
    TheString = Replace(TheString, ChrW(8084), ChrW(942))
    TheString = Replace(TheString, ChrW(8085), ChrW(942))
    TheString = Replace(TheString, ChrW(8086), ChrW(942))
    TheString = Replace(TheString, ChrW(8087), ChrW(942))
    TheString = Replace(TheString, ChrW(8088), ChrW(919))
    TheString = Replace(TheString, ChrW(8089), ChrW(919))
    TheString = Replace(TheString, ChrW(8090), ChrW(905))
    TheString = Replace(TheString, ChrW(8091), ChrW(905))
    TheString = Replace(TheString, ChrW(8092), ChrW(905))
    TheString = Replace(TheString, ChrW(8093), ChrW(905))
    TheString = Replace(TheString, ChrW(8094), ChrW(905))
    TheString = Replace(TheString, ChrW(8095), ChrW(905))
    TheString = Replace(TheString, ChrW(8096), ChrW(969))
    TheString = Replace(TheString, ChrW(8097), ChrW(969))
    TheString = Replace(TheString, ChrW(8098), ChrW(974))
    TheString = Replace(TheString, ChrW(8099), ChrW(974))
    TheString = Replace(TheString, ChrW(8100), ChrW(974))
    TheString = Replace(TheString, ChrW(8101), ChrW(974))
    TheString = Replace(TheString, ChrW(8102), ChrW(974))
    TheString = Replace(TheString, ChrW(8103), ChrW(974))
    TheString = Replace(TheString, ChrW(8104), ChrW(937))
    TheString = Replace(TheString, ChrW(8105), ChrW(937))
    TheString = Replace(TheString, ChrW(8106), ChrW(911))
    TheString = Replace(TheString, ChrW(8107), ChrW(911))
    TheString = Replace(TheString, ChrW(8108), ChrW(911))
    TheString = Replace(TheString, ChrW(8109), ChrW(911))
    TheString = Replace(TheString, ChrW(8110), ChrW(911))
    TheString = Replace(TheString, ChrW(8111), ChrW(911))
    TheString = Replace(TheString, ChrW(8112), ChrW(940))
    TheString = Replace(TheString, ChrW(8113), ChrW(940))
    TheString = Replace(TheString, ChrW(8114), ChrW(940))
    TheString = Replace(TheString, ChrW(8115), ChrW(945))
    TheString = Replace(TheString, ChrW(8116), ChrW(940))
    TheString = Replace(TheString, ChrW(8118), ChrW(940))
    TheString = Replace(TheString, ChrW(8119), ChrW(940))
    TheString = Replace(TheString, ChrW(8120), ChrW(902))
    TheString = Replace(TheString, ChrW(8121), ChrW(902))
    TheString = Replace(TheString, ChrW(8122), ChrW(902))
    TheString = Replace(TheString, ChrW(8123), ChrW(902))
    TheString = Replace(TheString, ChrW(8124), ChrW(913))
    TheString = Replace(TheString, ChrW(8125), ChrW(39))
    TheString = Replace(TheString, ChrW(8130), ChrW(942))
    TheString = Replace(TheString, ChrW(8131), ChrW(951))
    TheString = Replace(TheString, ChrW(8132), ChrW(942))
    TheString = Replace(TheString, ChrW(8134), ChrW(942))
    TheString = Replace(TheString, ChrW(8135), ChrW(942))
    TheString = Replace(TheString, ChrW(8136), ChrW(904))
    TheString = Replace(TheString, ChrW(8137), ChrW(904))
    TheString = Replace(TheString, ChrW(8138), ChrW(905))
    TheString = Replace(TheString, ChrW(8139), ChrW(905))
    TheString = Replace(TheString, ChrW(8140), ChrW(919))
    TheString = Replace(TheString, ChrW(8144), ChrW(943))
    TheString = Replace(TheString, ChrW(8145), ChrW(943))
    TheString = Replace(TheString, ChrW(8146), ChrW(912))
    TheString = Replace(TheString, ChrW(8147), ChrW(912))
    TheString = Replace(TheString, ChrW(8150), ChrW(943))
    TheString = Replace(TheString, ChrW(8151), ChrW(912))
    TheString = Replace(TheString, ChrW(8152), ChrW(906))
    TheString = Replace(TheString, ChrW(8153), ChrW(906))
    TheString = Replace(TheString, ChrW(8154), ChrW(906))
    TheString = Replace(TheString, ChrW(8155), ChrW(906))
    TheString = Replace(TheString, ChrW(8160), ChrW(973))
    TheString = Replace(TheString, ChrW(8161), ChrW(973))
    TheString = Replace(TheString, ChrW(8162), ChrW(944))
    TheString = Replace(TheString, ChrW(8163), ChrW(944))
    TheString = Replace(TheString, ChrW(8164), ChrW(961))
    TheString = Replace(TheString, ChrW(8165), ChrW(961))
    TheString = Replace(TheString, ChrW(8166), ChrW(973))
    TheString = Replace(TheString, ChrW(8167), ChrW(944))
    TheString = Replace(TheString, ChrW(8168), ChrW(910))
    TheString = Replace(TheString, ChrW(8169), ChrW(910))
    TheString = Replace(TheString, ChrW(8170), ChrW(910))
    TheString = Replace(TheString, ChrW(8171), ChrW(910))
    TheString = Replace(TheString, ChrW(8172), ChrW(929))
    TheString = Replace(TheString, ChrW(8178), ChrW(974))
    TheString = Replace(TheString, ChrW(8179), ChrW(969))
    TheString = Replace(TheString, ChrW(8180), ChrW(974))
    TheString = Replace(TheString, ChrW(8182), ChrW(974))
    TheString = Replace(TheString, ChrW(8183), ChrW(974))
    TheString = Replace(TheString, ChrW(8184), ChrW(908))
    TheString = Replace(TheString, ChrW(8185), ChrW(908))
    TheString = Replace(TheString, ChrW(8186), ChrW(911))
    TheString = Replace(TheString, ChrW(8187), ChrW(911))
    TheString = Replace(TheString, ChrW(8188), ChrW(937))
    TheString = Replace(TheString, ChrW(8127), ChrW(32))
    TheString = Replace(TheString, ChrW(8141), ChrW(900))
    TheString = Replace(TheString, ChrW(8142), ChrW(900))
    TheString = Replace(TheString, ChrW(8143), ChrW(900))
    TheString = Replace(TheString, ChrW(8157), ChrW(900))
    TheString = Replace(TheString, ChrW(8158), ChrW(900))
    TheString = Replace(TheString, ChrW(8159), ChrW(900))
    TheString = Replace(TheString, ChrW(8175), ChrW(900))
    TheString = Replace(TheString, ChrW(8189), ChrW(900))
    TheString = Replace(TheString, ChrW(8190), ChrW(32))
    
    ActiveWindow.Selection = TheString
    
    If Len(ActiveWindow.Selection) > 1 Then
    MsgBox ("Execute Time:    " & (Timer - sngStart) & " seconds            ") & vbLf & "Total Characters:  " & Format(Len(Replace(TheString, vbCrLf, "")), "#,###             "), vbInformation, "Execute time - Total Characters"
    End If
    
    End Sub
    

    Θα επανέλθω με το πρόβλημα που αντιμετωπίζω σχετικά με UNICODE χαρακτήρες.
    Ευχαριστώ πολύ.

  2. Ο/Η T. Papadimitriou λέει:

    Δυστυχώς, το σχόλιο που έστειλα είναι χωρίς τη μακροεντολή (μετατροπή Πολυτονικού κειμένου σε Μονοτονικό). Έγινε περικοπή μέρους του σχολίου.
    Υπάρχει τρόπος να σας στείλω ολόκληρη τη μακροεντολή (περίπου 13.000 χαρακτήρες) ή ένα έγγραφο του word;
    Ευχαριστώ πολύ.

  3. Ο/Η vioannis λέει:

    Τάσο.
    Ότι περικλείεται σε γωνιακές αγκύλες (μικρότερο, μεγαλύτερο), η WordPress το διαγράφει.Σου έστειλα ένα email για να μου στείλεις τον κώδικα σε word, και θα τον αποκαταστήσω. Επίσης δες εδώ για το πως ανεβάζεις κώδικα στην WordPress:
    http://en.support.wordpress.com/code/posting-source-code/

  4. Ο/Η vioannis λέει:

    Τάσο, τώρα ο κώδικας πρέπει να είναι σωστός. Θα τον τεστάρω αύριο, και θα σου γράψω τις σκέψεις μου.

  5. Ο/Η T. Papadimitriou λέει:

    Πήρα copy τον κώδικα από εδώ και τον χρησιμοποίησα. Κανένα πρόβλημα!

  6. Ο/Η vioannis λέει:

    Τάσο, είναι πέρα από κάθε αμφιβολία ότι ο κώδικας που έγραψες, με τη συνάρτηση Replace, είναι κατά πολύ ταχύτερος του δικού μου. Για την ακρίβεια ο δικός μου κώδικας είναι εξαιρετικά αργός (έως απαγορευτικός) για μεγάλα κείμενα. Είναι αλήθεια ότι όταν τον έγραφα, δεν με απασχόλησαν θέματα ταχύτητας. Ήθελα, απλά, να δώσω ένα εργαλείο που να κάνει τη “χοντρή” δουλειά σε κάποιον που ήθελε να μεταγράψει ένα πολυτονικό κείμενο. Άλλωστε όπως λέω και στο σημείωμα, η μακροεντολή δεν παίρνει ορθογραφικές αποφάσεις. Αυτός που θα την χρησιμοποιήσει πρέπει να ξαναπεράσει χειριστικά το κείμενο και να κάνει διορθώσεις σε μονοσύλλαβες λέξεις κλπ.
    Η μάκρο που έστειλες, και σε ευχαριστώ πολύ που μοιράστηκες τη δουλεία σου με όλους τους φίλους του ιστολογίου, είναι πολύ αποτελεσματική και γρήγορη ακόμα και με ολόκληρα βιβλία. Την δοκίμασα σε τρεις διαφορετικούς υπολογιστές, με 2003,2007 και 2010 αντίστοιχα, και για κείμενο 90.000 λέξεων χρειάστηκε 5-7 δεύτερα. Δεν μπορώ να φανταστώ κάτι ποιο γρήγορο. Περιμένω και άλλες τέτοιες ωραίες δουλειές σου να τις φιλοξενήσω στο ιστολόγιο!

  7. Ο/Η T. Papadimitriou λέει:

    Φίλε Γιάννη, σε ευχαριστώ που ασχολήθηκες με το θέμα αυτό. Συμφωνώ με αυτά που λες και σίγουρα άλλο είναι δημιουργία κώδικα που απαιτεί σοβαρή πνευματική εργασία και άλλο με μια απλή διαδικασία όπως με τη χρήση «Replace».
    Σε συνέχεια όμως σχετικά με το θέμα ταχύτητας ..και μαζικότητας – σημερινά χαρακτηριστικά, θα ήθελα να προσθέσω πως μπορεί να βελτιωθεί ακόμη λίγο η ταχύτητα αν προσθέσουμε στη γραμμή 6 του κώδικα:

    Application.ScreenUpdating = False
    Application.StatusBar = False ' ή κάποιο μήνυμα πχ. Παρακαλώ υπομονή .... 
    

    και να επαναφέρουμε στις βασικές ρυθμίσεις προσθέτοντας στο τέλος του κώδικα -γραμμή 259-:

    Application.ScreenUpdating = True
    Application.StatusBar = True
    

    Με αυτές τις αλλαγές μπορεί να αυξηθεί ακόμη η ταχύτητα.
    Επιπλέον για λόγους εμφάνισης θα μπορέσουμε να προσθέσουμε αν επιθυμούμε στη γραμμή 259 του παραπάνω κώδικα εντολές μορφοποίησης:

            With Selection.Font
                .Name = "Calibri"   ' ή ότι θέλουμε
                .Size = 11
                .Bold = False
                .Italic = False
                .Color = wdColorBlack
            End With
    

    Καταφέραμε λοιπόν να μετατρέψουμε πολυτονικό κείμενο σε μονοτονικό χωρίς όμως ορθογραφικές διορθώσεις. Αυτό όπως μπορεί να γίνει ΜΕΡΙΚΩΣ πάλι με τη χρήση Replace. Έτσι, για παράδειγμα, θα μπορούσαμε να χρησιμοποιήσουμε για τον σύνδεσμο «καί» έχει τόνο, αντικατάσταση με «και» χωρίς τόνο πχ.

    TheString = Replace(TheString, " καί ", " και ")  ' με κενό στην αρχή και στο τέλος
    TheString = Replace(TheString, " τό ", " το ")          ' κ.ο.κ.
    

    Τι θα έλεγες και για «Greeklish»;

    -Να φανταστείς ότι μονοτονικό και Greeklish δεν τα συμπαθώ!

  8. Ο/Η T. Papadimitriou λέει:

    Πρόβλημα!
    Πώς μπορούμε να εντοπίσουμε έστω και έναν πολυτονικό χαρακτήρα μέσα σε μονοτονικό κείμενο;
    Έχω φτιάξει την παρακάτω μακροεντολή αλλά νομίζω ότι κάπου αναζητώ πιο γρήγορο εντοπισμό και κάλυψη μεγαλύτερου εύρους χαρακτήρων και όχι μόνο από κωδικό 7936 έως 8190 αλλά και από 976 μέχρι 1013.

    Sub TestIfPopytonic()
    Dim TheString As String
    TheString = ActiveWindow.Selection
    If Len(TheString) < 2 Then MsgBox " Επιλέξτε κείμενο            ", vbExclamation, " Test if Polytonic"
    Dim i As Integer
        For i = 7936 To 8190
            If Results = InStr(TheString, ChrW(i)) = 0 Then
            MsgBox "For your attention:" & vbLf & """One or more characters are Polytonic""     ", vbInformation, " Results"
            Exit For
            End If
        Next
    End Sub 

    Υπάρχει κάτι καλύτερο;
    Ευχαριστώ.

  9. Ο/Η vioannis λέει:

    Αγαπητέ Τάσο, το πρόβλημα που έβαλες για την αναζήτηση των πολυτονικών χαρακτήρων, είναι πολύ ενδιαφέρον, θέλω λίγο χρόνο να το δω. Eν τω μεταξύ ξανακοίταξε τον κώδικα που ανέβασες, μάλλον δεν έχεις ορίσει τη Results. Με τα Greeklish, αφού οριστούν οι κανόνες αντικατάστασης, δεν μπορεί να γραφτεί εντελώς παρόμοια με τη Sub PolyToMono,η μακροεντολή; Στην δικιά μου (όχι βέβαια γρήγορη) εκδοχή έχω δουλέψει εντελώς παρόμοια.

  10. Ο/Η T. Papadimitriou λέει:

    Καλημέρα σας.
    Ο κώδικας που ανέβασα είναι μέρος ευρύτερης εργασίας και ο σκοπός είναι να εντοπίζει έστω και έναν (τον πρώτο) πολυτονικό χαρακτήρα και να γίνεται διακοπή της διεργασίας. Αυτό δεν το κατάφερα με αποτέλεσμα τη βραδυπορία. Ο κώδικας ψάχνει ολόκληρο το κείμενο ακόμη και αν ο πολυτονικός χαρακτήρας είναι πρώτος στο κείμενο!
    Όσο για το εύρος της αναζήτησης απλά τώρα έχω βάλει για τους υπόλοιπους χαρακτήρες που θέλω:

    '... Προσθήκη στον κώδικα: Sub TestIfPopytonic(), Line 12
        For j = 976 To 1013
            If Results = InStr(TheString, ChrW(j)) = 0 Then
             MsgBox "For your attention:" & vbLf & """One or more characters are Polytonic""     ", vbInformation, " Results"
               Exit For
            End If
        Next
    '... * If, for, next, loop... κτλ καλό είναι να αποφεύγουμε.
    

    Η βασική μου σκέψη είναι: Ελληνικό Κείμενο (πολυτονικό ή μονοτονικό) >> Μεταγραφή σε Λατινικούς Χαρακτήρες με κανόνες ΕΛΟΤ 743-2 (για Έλληνες) ή ISO 843-2 (Διεθνώς).
    Τα Greeklish είναι μια παράπλευρη κατάσταση, και επειδή μέσα στην αναζήτηση αυτή για ΕΛΟΤ 743-2 είναι εύκολο να κάνει κανείς, όπως είπες, την ίδια εργασία με τη Sub PolyToMono. Αυτός είναι ο λόγος που το ανέφερα. Εκείνο όμως που θα ήθελα να πω, είναι πως οι περισσότεροι για λόγους ευκολίας(?) έχουν τους χαρακτήρες με κεφαλαία. Είναι κάτι που δεν θέλω.
    Προσπαθώ να πετύχω το εξής: ό,τι και όπως είναι γραμμένο (κεφαλαία ή πεζά), να μεταγραφεί σε λατινικούς χαρακτήρες (με βάση τους υποχρεωτικούς-νομικούς κανόνες μεταγραφής).
    Αν λύσω το παραπάνω πρόβλημα του κώδικα, είναι το πρώτο από τα δύο που έχω αυτή τη στιγμή.
    Το άλλο σχετίζεται με την αντιγραφή και επικόλληση σε UserForm TextBox των Unicode χαρακτήρων.
    Θα το συζητήσουμε εδώ, αν υπάρχει βέβαια και η διάθεση για αυτό, μια άλλη φορά.
    Ευχαριστώ πολύ.

  11. Ο/Η vioannis λέει:

    Αγαπητέ Τάσο,
    Δύο μάκρο, παραλλαγές πάνω στον δικό σου κώδικα, που σταματάνε μόλις βρουν τον πρώτο πολυτονικό χαρακτήρα:

    Sub testA()
    Dim TheString As Object
    Dim gramma As String
    Dim UnicodeGramma As Long
    Dim g As Long
    Dim i As Long
    Set TheString = Selection
    For g = 1 To Len(TheString)
        gramma = Mid(TheString, g, 1)
        UnicodeGramma = AscW(gramma)
        For i = 7936 To 8190
            If UnicodeGramma = i Then
            MsgBox "Πολυτονικός Χαρακτήρας στη θέση: " & g
            GoTo myExitFor
            End If
        Next
    Next
    myExitFor:
    '----------------
    'και άλλος κώδικας εδώ
    '----------------
    End Sub
    

    Με την vba συνάρτηση Mid παίρνω ένα-ένα τα γράμματα του επιλεγμένου κειμένου (TheString) και ελέγχω αν ο Unicode Κωδικός του γράμματος ανήκει στο διάστημα από 7936 έως 8190. Για τον πρώτο χαρακτήρα που θα διαπιστωθεί αυτό, φεύγω (πηδάω) έξω από τα for..next και στέλνω τον κώδικα να συνεχίσει στο myExitFor:
    Για να αποφύγεις να τρέξεις χωριστά τις περιοχές 7936 έως 8190 και 976 έως 1013 και επειδή στις περιοχές αυτές υπάρχουν και άλλοι χαρακτήρες εκτός από πολυτονικούς, προτείνω την παρακάτω εκδοχή: Σχηματίζεις ένα πίνακα (array) που περιέχει όλους τους κωδικούς των πολυτονικών και μόνο αυτούς. Στον πίνακα βάζεις τους κωδικούς με όποια σειρά θέλεις, (ίσως τους πιο συχνά εμφανιζόμενους στην αρχή του πίνακα και χαρακτήρες με υπογεγραμμένη που υποθέτω ότι είναι πιο σπάνιοι προς το τέλος, κλείνω την παρένθεση διότι δεν είμαι καλός στη γραμματική). Η μεταβλητη i διατρέχει τον πίνακα αυτό και όχι περιοχές αριθμών. Αν στο μέλλον θέλεις να προσθέσεις ή να αφαιρέσεις χαρακτήρες, απλά προσθέτεις ή αφαιρείς τους αντίστοιχους αριθμούς από τον πίνακα. Στο επόμενο παράδειγμα στον πίνακας (PolyArray) έχω βάλει μόνο λίγους αριθμούς.

    Sub testB()
    Dim TheString As Object
    Dim gramma As String
    Dim UnicodeGramma As Long
    Dim g As Long
    Dim i As Long
    Dim PolyArray As Variant
    PolyArray = Array(7936, 7937, 7938, 7939, 7940, 976, 977, 1013)
    Set TheString = Selection
    For g = 1 To Len(TheString)
        gramma = Mid(TheString, g, 1)
        UnicodeGramma = AscW(gramma)
        For i = LBound(PolyArray) To UBound(PolyArray)
            If UnicodeGramma = PolyArray(i) Then
            MsgBox "Πολυτονικός Χαρακτήρας: " & g
            GoTo myExitFor
            End If
        Next
    Next
    myExitFor:
    '----------------
    'και άλλος κώδικας εδώ
    '----------------
    End Sub 
    

    Ελπίζω να έδωσα κάποια ιδέα, τα ξαναλέμε.

  12. Μια και είδα τη συζήτησή σας, σκέφθηκα να θέσω στη διάθεση κάθε ενδιαφερόμενου μία μεγάλη σειρά μακροεντολών που έχω αναπτύξει εδώ και αρκετά χρόνια, η οποία κάνει τις εξής εργασίες σε περιβάλλον Word:

    1. Μπορεί γρήγορα και σωστά να μετατρέψει πολυτονικό κείμενο σε μονοτονικό.
    2. Μπορεί (με κάποια καθυστέρηση λόγω όγκου), να διορθώσει αυτόματα το 90% τών λαθών σε Ελληνικά κείμενα που σκαναρίσθηκαν και έχουν λάθη ή λόγω πολυτονικού, ή λόγω κακού σκαναρίσματος. Μιλάμε για δεκάδες χιλιάδες πιθανές διορθώσεις λέξεων ή φράσεων, που διαρκώς συμπληρώνονται.
    3. Μπορεί (επίσης με κάποια καθυστέρηση λόγω όγκου), να μετατρέψει αρχαίες ή αρχαΐζουσες λέξεις σε δημοτική, σε κείμενα που θέλει κάποιος να μεταφράσει σε νέα Ελληνικά. Εννοείται ότι αυτές οι μακροεντολές απλώς κάνουν την απλούστερη εργασία ρουτίνας, αφήνοντας τα περισσότερα στον μεταφραστή.
    4. Υπάρχει μαζί και μια σειρά μακροεντολών, που βοηθάει στον εμπλουτισμό τών ανωτέρω μακροεντολών, με κατασκευή συμπληρωματικών μακροεντολών, που κάνουν τα παραπάνω πακέτα όλο και καλύτερα.

    Δεδομένου ότι είμαι σχεδόν άσχετος με προγραμματισμό μακροεντολών, ξέρω ότι σίγουρα υπάρχουν και πολύ καλύτεροι και συντομότεροι τρόποι να γίνουν οι παραπάνω εργασίες, αλλά τόσο ήξερα, τόσο έκανα. Ίσως με βάση τα παραπάνω, κάποιος να μπορεί είτε να συντομέψει τις διεργασίες, είτε να τις εμπλουτίσει.

    Το γεγονός είναι ότι το σύστημα αυτό δουλεύει καλά, και με έχει γλιτώσει από πολλές ώρες διορθώσεων σε σκαναρισμένα κείμενα που μεταφέρω από εικόνα σε Word προς δημοσίευση.

    Αν κάποιος ενδιαφέρεται να τα λάβει δωρεάν, ας επικοινωνήσει μαζί μου μέσω πριβέ μηνύματος Φέισμπουκ.

Τα σχόλια είναι απενεργοποιημένα.