Sub Ajami_Romain()
'
' Version 1.1 du 24 février 2011. Faute de Galen Currah, galen@currah.us
' Transcrit un texte en ajami dans des caractères romains.
' Écrit en Visual Basic pour Applications(R), le langage des macro pour Word 2003, 2007, 2010.
' Source libre.

' ============ CRÉE DES VARIABLES ET LEUR ASSIGNE DES VALUES =============

' VARIABLES
Dim I, J As Long
Dim Ajami(&H7FF) As String
Dim A, B, C, S, T As String
Dim Vowels, Punctuation
Const Digits = "0123456789"

' VALEURS
Vowels = "aàëeéioóu" ' Vowels
Punctuation = ".,:;?!(){}[]<>-" & ChrW(&H150) & ChrW(&H151)
For I = 32 To 255: Ajami(I) = Chr(I): Next I
For I = 256 To &H7FF: Ajami(I) = ChrW(I): Next I

'POINTS UNICODES POUR LA POLICE SENAJAMIGRG.TTF
Ajami(&H622) = "|aa"
Ajami(&H60C) = ChrW(&H2C)
Ajami(&H627) = ChrW(&H7C)
Ajami(&H639) = ChrW(&H27)
Ajami(&H628) = ChrW(&H62)
Ajami(&H67F) = ChrW(&H253)
Ajami(&H680) = ChrW(&H253)
Ajami(&H756) = ChrW(&H63)
Ajami(&H686) = ChrW(&H63)
Ajami(&H684) = ChrW(&H188)
Ajami(&H62F) = ChrW(&H64)
Ajami(&H636) = ChrW(&H44)
Ajami(&H630) = ChrW(&H44)
Ajami(&H637) = ChrW(&H257)
Ajami(&H641) = ChrW(&H66)
Ajami(&H6A2) = ChrW(&H66)
Ajami(&H6AF) = ChrW(&H67)
Ajami(&H63A) = ChrW(&H67)
Ajami(&H640) = ChrW(&H5F)
Ajami(&H647) = ChrW(&H68)
Ajami(&H62D) = ChrW(&H68)
Ajami(&H62C) = ChrW(&H6A)
Ajami(&H6A9) = ChrW(&H6B)
Ajami(&H643) = ChrW(&H6B)
Ajami(&H644) = ChrW(&H6C)
Ajami(&H645) = ChrW(&H6D)
Ajami(&H751) = "mb"
Ajami(&H646) = ChrW(&H6E)
Ajami(&H6BA) = ChrW(&H6E)
Ajami(&H68E) = "nd"
Ajami(&H763) = "ng"
Ajami(&H767) = ChrW(&HF1)
Ajami(&H6D1) = ChrW(&HF1)
Ajami(&H75D) = ChrW(&H14B)
Ajami(&H764) = ChrW(&H14B)
Ajami(&H752) = ChrW(&H70)
Ajami(&H755) = ChrW(&H1A5)
Ajami(&H642) = ChrW(&H71)
Ajami(&H631) = ChrW(&H72)
Ajami(&H633) = ChrW(&H73)
Ajami(&H635) = ChrW(&H73)
Ajami(&H634) = ChrW(&H283)
Ajami(&H62A) = ChrW(&H74)
Ajami(&H638) = ChrW(&H54)
Ajami(&H69F) = ChrW(&H1AD)
Ajami(&H648) = ChrW(&H77)
Ajami(&H62E) = ChrW(&H78)
Ajami(&H64A) = ChrW(&H79)
Ajami(&H683) = ChrW(&H1B4)
Ajami(&H678) = ChrW(&H1B4)
Ajami(&H632) = ChrW(&H7A)
Ajami(&H653) = "aa"
Ajami(&H64E) = ChrW(&H61)
Ajami(&H65A) = ChrW(&HE0) ' à
Ajami(&H8F5) = ChrW(&HE0) ' à Unicode 6.1
Ajami(&H65E) = ChrW(&HEB) ' ë
Ajami(&H8F4) = ChrW(&HEB) ' ë Unicode 6.1
Ajami(&H65C) = ChrW(&H65)
Ajami(&H655) = ChrW(&H65) ' e
Ajami(&H8F9) = ChrW(&H65) ' e Unicode 6.1
Ajami(&H656) = ChrW(&HE9) ' é
Ajami(&H8FA) = ChrW(&HE9) ' é Unicode 6.1
Ajami(&H650) = ChrW(&H69)
Ajami(&H65D) = ChrW(&H6F) ' o
Ajami(&H8F7) = ChrW(&H6F) ' o Unicode 6.1
Ajami(&H65B) = ChrW(&H6F)
Ajami(&H657) = ChrW(&HF3)
Ajami(&H64F) = ChrW(&H75)
Ajami(&H652) = ChrW(&HB0)
Ajami(&H651) = ChrW(&H7E)
Ajami(&H621) = ChrW(&H60)

'METTRE LE TEXTE AJAMI DANS LE VARIABLE S
S = ActiveWindow.ActivePane.Selection

'Vérifie s'il y a du texte sélectionné
If Len(S) < 2 Then
    S = "You must select some text to transcribe." & vbCr & vbCr & "Il faut sélectionner du texte à transcrire."
    I = MsgBox(S, vbCritical & vbOKOnly, "Attention!")
    GoTo Oops
End If

'CONVERTIR EN ROMAIN TOUS LES CARACTÈRES AJAMI DANS LE VARIABLE T
For I = 1 To Len(S)
    T = T & Ajami(AscW(Mid(S, I, 1)))
Next I

'Ajoute un espace à chaque bout du variable T
T = Chr(32) & T & Chr(32)

'OUVRIT UN DOCUMENT BLANCE
Documents.Add , , , True

'ASSIGNE AU DOCUMENT DES ATTRIBUTS DE POLICE
ActiveWindow.Selection.WholeStory               ' Select whole document
ActiveWindow.ActivePane.Selection = vbCrLf      ' Put white space for the next to line to work on
ActiveWindow.Selection.Font.Name = "Arial"      ' Set font [this legal command does not always work!]
ActiveWindow.Selection.Font.Size = 12           ' Set font size [this legal command does not work!]
ActiveWindow.ActivePane.Selection.MoveRight

' ============ LIT UN CARACTÈRES DU VARIABLE T, LE TRAITE, PUIS REVIENT =============
'Met le conteur
I = 2
   
'Fin du variable T ?
Do While I < (Len(T) - 1)
    
    'B = caractère précédent, C = caractère currant, D = caractère suivant
    B = Mid(T, I - 1, 1):    C = Mid(T, I, 1):    D = Mid(T, I + 1, 1)
    
    'Ponctuation ou espace?
    If InStr(Punctuation & Chr(32), C) > 0 Then GoTo Skip
    
    'voyelle longue?
    If ((InStr(Vowels, B) > 0) And (InStr(Vowels & "°", D) = 0)) Then
        Select Case C
        Case "|"
            C = "a"
        Case "y"
            C = "e"
        Case "w"
            C = B
        End Select
        'GoTo Skip
    End If
        
    'consonne géminée ou pair nasale sans voyelle?
    If D = "~" And InStr("mn", B) = 0 Then Mid(T, I + 1, 1) = C: GoTo Skip

    'Enlève les diacritiques
    If InStr("°|~", C) > 0 Then GoTo Hop
    
Skip:
    'INSÈRE LE CARACTÈRE ROMAIN DANS LE DOCUMENT
    ActiveWindow.ActivePane.Selection = C
    ActiveWindow.ActivePane.Selection.MoveRight
    
'N'affiche pas le caractère
Hop:

    'Incrémenter le conteur
    I = I + 1

Loop

End Sub