Attribute VB_Name = "NewNotationConvertorWord2007"
'This macro has been verified on 2011/03/09 by Hélène Hauduc
'This macro aims at updating former ASM-type model notation in a Word2007 document
'This allow to modify notation both inside text and equation objects
'The file "New-Notation.xls" is required for this macro

Sub NewNotationConvertorWord2007()
    Dim FindStringArray() As String 'Array with former notation
    Dim ReplaceStringArray() As String 'Array with new notation
    Dim ArrayEnd As Integer
    Dim Chemin As String
    Dim xlApp As Object
    Dim xlWb As Object
    Dim xlSh As Object
    Dim iR As Integer 'number of rows (characters to replace) in the Excel sheet
    Dim i As Integer
    Dim lgth0, lgth1, lgth2, b1, b2, b3 As Integer
    Dim subs As String
    Dim notat As String

    'Open Excel
    Chemin = ThisDocument.Path
    Set xlApp = GetObject(, "Excel.application")
    Set xlWb = xlApp.Workbooks.Open(Chemin & "\NewNotationConvertor-Word2007.xlsx")
    Set xlSh = xlWb.Worksheets(1)
    
    'number of raws (characters to replace)
    iR = 1
    Do While xlSh.Cells(1, iR + 1).Value <> ""
        iR = iR + 1
    Loop
    
    'Arrays of old and new notation to be replaced
    ReDim FindStringArray(iR - 1)
    ReDim ReplaceStringArray(iR - 1)
    
    'Loop to read table
    For i = 2 To iR 'First raw contain titles : start at i=2
        FindStringArray(i - 1) = xlSh.Cells(i, 1).Value 'Array with former notation
        ReplaceStringArray(i - 1) = xlSh.Cells(i, 2).Value 'Array with new notation
    Next i
    
    'Quit Excel
    xlWb.Close
    xlApp.Quit
    Set xlSh = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    


' Find and replace
    ' for each Find
    For i = 1 To iR - 1
    
        'initialisation New notation
        b1 = 0 'position of "_"
        b2 = 0  'length parameter
        b3 = 0  'position of "^"
        lgth0 = 0 'main letter length
        lgth1 = 0 'subscript length
        lght2 = 0 'upperscript length
        notat = "" 'main letter
        subs = "" 'subscript
        supers = "" 'upperscript
        
        notat = ReplaceStringArray(i)
        b1 = InStr(notat, "_")
        b2 = Len(notat)
        b3 = InStr(notat, "^")
        Firstlevel = Mid(notat, 1, b1 - 1)
        lgth0 = Len(Firstlevel)
        
        If b3 = 0 Then
            subs = Mid(notat, b1 + 1, b2 - b1)
            'If InStr(subs, "(") > 0 Then subs = Mid(subs, 2, Len(subs) - 2)
            lgth1 = Len(subs)
            Else
            subs = Mid(notat, b1 + 1, b3 - b1 - 1)
            supers = Mid(notat, b3 + 1, b2 - b3)
            lgth1 = Len(subs)
            lgth2 = Len(supers)
        End If
               
        'Initialisation Old notation
        ob1 = 0 'position of "_"
        ob2 = 0  'length parameter
        ob3 = 0  'position of "^"
        olgth0 = 0 'main letter length
        olgth1 = 0 'subscript length
        olght2 = 0 'upperscript length
        onotat = "" 'main letter
        osubs = "" 'subscript
        osupers = "" 'upperscript
        
        oldparam = FindStringArray(i)
        ob1 = InStr(oldparam, "_")
        ob2 = Len(oldparam)
        ob3 = InStr(oldparam, "^")
        oFirstlevel = Mid(oldparam, 1, b1 - 1)
        olgth0 = Len(Firstlevel)
        
        If ob3 = 0 Then
            osubs = Mid(oldparam, ob1 + 1, ob2 - ob1)
            olgth1 = Len(osubs)
            Else
            osubs = Mid(oldparam, ob1 + 1, ob3 - ob1 - 1)
            osupers = Mid(oldparam, ob3 + 1, ob2 - ob3)
        End If
               
        '************************************************************************
        'in text
        
        With Selection.Find
            .Wrap = wdFindContinue
            .Forward = True
            .MatchWholeWord = True
            .MatchCase = True
            .Text = oFirstlevel & osubs & osupers
            .Replacement.Text = ""
        End With
        
        b = True
        Do While b = True
            With Selection
                'selection
                .Find.Execute
                
                'If selection is the variable to change
                If Selection = oFirstlevel & osubs & osupers Then
                    b = True
                    Else: b = False 'else exit loop, next i
                    Exit Do
                End If
                
                'write the firstlevel
                .TypeText Text:=Firstlevel
                .MoveLeft Unit:=wdCharacter, Count:=lgth0, Extend:=lgth0
                .Font.Italic = True
                
                'write the subscript
                .MoveRight Unit:=wdCharacter, Count:=1
                .TypeText Text:=subs
                'change font of subscript
                .MoveLeft Unit:=wdCharacter, Count:=lgth1, Extend:=lgth1
                .Font.Subscript = True
                .Font.Italic = False
                
                'write the superscript
                If b3 <> 0 Then
                    .MoveRight Unit:=wdCharacter, Count:=1
                    .TypeText Text:=supers
                    'change font of superscript
                    .MoveLeft Unit:=wdCharacter, Count:=lgth2, Extend:=lgth2
                    .Font.Superscript = True
                End If
                
                'change position of cursor
                .MoveRight Unit:=wdCharacter, Count:=1
            End With
        Loop
        '******************************************************************************
        'in equations
        Dim equations As OMaths
        nbeq = ActiveDocument.OMaths.Count  'number of equations
        Set equations = ActiveDocument.OMaths 'collection of equations
            For eq = 1 To nbeq  'for each equation
                Set equation = equations.Item(eq)
                equation.Linearize
                equation.ConvertToNormalText
                
                If osupers <> "" Then
                    OldNotation = "(" & oFirstlevel & "_" & osubs & "?" & osupers & ")"
                    Else
                    OldNotation = "(" & oFirstlevel & "_" & osubs & ")"
                End If
                
                If osupers <> "" Then
                    NewNotation = "(" & Firstlevel & "_" & subs & "^^" & supers & ")"
                    Else
                    NewNotation = "(" & Firstlevel & "_" & subs & ")"
                End If

                With Selection.Find
                    .Text = OldNotation
                    .Replacement.Text = NewNotation
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = True
                    .MatchCase = True
                    .MatchWholeWord = False
                    .MatchWildcards = True
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                    With Selection
                        .Find.Execute Replace:=wdReplaceAll
                    End With
            equation.ConvertToMathText
            equation.BuildUp
            

        Next 'eq
    Next 'i

End Sub