Attribute VB_Name = "Module11"
Public NUMBER_SYMBOL_TABLE As Integer
Public Type SYMBOL_TABLE
    name As String
    font As String
    number As Integer
End Type
Public symbolTable() As SYMBOL_TABLE

Public Const SYMTBL = "\alpha,      symbol,  97,  \a,          symbol,  97,    \beta,       symbol,  98,    \gamma,      symbol, 103," & _
"\delta,      symbol, 100,  \epsilon,    symbol, 101,    \e,          symbol, 101,    \varepsilon, symbol, 101," & _
"\zeta,       symbol, 122,  \eta,        symbol, 104,    \theta,      symbol, 113,    \vartheta,   symbol,  74," & _
"\kappa,      symbol, 107,  \lambda,     symbol, 108,    \mu,         symbol, 109,    \nu,         symbol, 110," & _
"\xi,         symbol, 120,  \pi,         symbol, 112,    \rho,        symbol, 114,    \sigma,      symbol, 115," & _
"\varsigma,   symbol, 122,  \tau,        symbol, 116,    \upsilon,    symbol, 117,    \phi,        symbol, 121," & _
"\chi,        symbol,  99,  \phi,        symbol, 102,    \omega,      symbol, 119,    \Gamma,      symbol,  71," & _
"\Delta,      symbol,  68,  \Theta,      symbol,  81,    \Lambda,     symbol,  76,    \Xi,         symbol,  88," & _
"\Pi,         symbol,  80,  \Sigma,      symbol,  83,    \Phi,        symbol,  70,    \Psi,        symbol,  89," & _
"\Omega,      symbol,  87,  \approx,     symbol, 187,    \backslash,  arial,   47,    \bigcap,     symbol, 200," & _
"\bigcup,     symbol, 199,  \bigvee,     symbol, 218,    \bigwedge,   symbol, 217,    \cap,        symbol, 200," & _
"\cdot,       arial,  183,  \cup,        symbol, 199,    \equiv,      symbol, 186,    \exists,     symbol,  36," & _
"\forall,     symbol,  34,  \ge,         symbol, 179,    \geq,        symbol, 179,    \in,         symbol, 206," & _
"\infty,      symbol, 165,  \int,        symbol, 242,    \land,       symbol, 217,    \lceil,      symbol, 233," & _
"\Leftarrow,  symbol, 220,  \leftarrow,  symbol, 172,    \le,         symbol, 163,    \leq,        symbol, 163," & _
"\lfloor,     symbol, 235,  \lor,        symbol, 218,    \ne,         symbol, 216,    \neq,        symbol, 185," & _
"\notin,      symbol, 270,  \oplus,      symbol, 197,    \otimes,     symbol, 196,    " & _
"\prod,       symbol, 213,  \rceil,      symbol, 249,    \rfloor,     symbol, 251,    \Rightarrow, symbol, 222," & _
"\rightarrow, symbol, 174,  \subset,     symbol, 204,    \subseteq,   symbol, 205,    \sum,        symbol, 229," & _
"\supset,     symbol, 201,  \supseteq,   symbol, 202,    \times,      arial,  215,    \union,      symbol, 199," & _
"\vee,        symbol, 218,  \wedge,      symbol, 217,    {1 \over 2}, arial,  189,    {1 \over 4}, arial,  188," & _
"{3 \over 4}, arial,  190,  \over,       arial,   47"

Sub latex2ppt()
  Call lineFormatting
  Call Eqn
End Sub

Sub Eqn()
  Call mathColor
  Call superscript_subscript
  Call convertSymbol
End Sub

Sub convertSymbol()
'
'convert the symbols appeared in the symbol table.
'Read file('symbols.txt') and store into the symbols class module.
'
Dim i As Integer
Dim sld As Slide, shp As Shape, txtRng As TextRange, foundText As TextRange

'store the symboltable, when fail to read, return False
InitSymbolTable

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then
        For i = 1 To NUMBER_SYMBOL_TABLE
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(symbolTable(i).name, , msoTrue)
            Do While Not (foundText Is Nothing)
                foundText.font.name = symbolTable(i).font
                Set foundText = foundText.Replace(symbolTable(i).name, " ")
                Set foundText = foundText.InsertSymbol(symbolTable(i).font, _
                                            symbolTable(i).number, msoTrue)
                
                Set foundText = txtRng.Find(symbolTable(i).name, _
                        foundText.start + foundText.Length - 1, msoTrue)
            Loop
        Next
    End If
   Next
Next

End Sub

Private Function InitSymbolTable()
'
'initialize symbolTable from constant string, SYMTBL
'
Dim i As Integer, token As String, j As Integer
Dim tmpTable() As SYMBOL_TABLE, tmp As SYMBOL_TABLE

i = 1

NUMBER_SYMBOL_TABLE = 40
ReDim tmpTable(NUMBER_SYMBOL_TABLE)
token = getToken(SYMTBL, ",", 1)
While token <> ""
    tmpTable(i).name = token
    tmpTable(i).font = getToken(SYMTBL, ",", -1)
    tmpTable(i).number = Val(getToken(SYMTBL, ",", -1))
    token = getToken(SYMTBL, ",", -1)
    i = i + 1
    
    If i > UBound(tmpTable) Then ReDim Preserve tmpTable(i + 10)
Wend

NUMBER_SYMBOL_TABLE = i - 1
ReDim symbolTable(NUMBER_SYMBOL_TABLE)

'Sort the table according to the length of name in descending order
For i = 1 To NUMBER_SYMBOL_TABLE - 1
    For j = 1 To NUMBER_SYMBOL_TABLE - 1
        If Len(tmpTable(j).name) < Len(tmpTable(j + 1).name) Then
            tmp = tmpTable(j)
            tmpTable(j) = tmpTable(j + 1)
            tmpTable(j + 1) = tmp
        End If
    Next
Next

For i = 1 To NUMBER_SYMBOL_TABLE
    symbolTable(i) = tmpTable(i)
Next
End Function

Public Function getToken(src As String, sep As String, start As Integer) As String
Static lStart As Integer
Dim tmp As Integer

If start <> -1 Then lStart = start

tmp = InStr(lStart, src, sep, 1)    'search sep from the src starting from lStart
If tmp = 0 Then   'if the sep is not found
    If lStart < Len(src) Then
        getToken = Trim(Mid(src, lStart))
        lStart = Len(src)
    Else
        getToken = ""
    End If
Else
    getToken = Trim(Mid(src, lStart, tmp - lStart))
    lStart = tmp + 1
End If

End Function


Sub superscript_subscript()
'
'Change texts with symbols of superscript or subscript into texts in super..or subscript
'
scriptGroup "^", "{", "}", True
scriptGroup "_", "{", "}", False
End Sub

Sub scriptGroup(first As String, br1 As String, br2 As String, bSuper As Boolean)
'
' superscrpt/subscript
'
Dim txtRng As TextRange, foundText As TextRange, tmpText As TextRange
Dim count, scr_cnt, scr_start, scr_end As Integer

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            
            Set foundText = txtRng.Find(first)
            
DO1:        Do While Not (foundText Is Nothing)
            
                count = 0 'initialize count
                scr_start = foundText.start
                scr_end = foundText.start
                
                If txtRng.Characters(foundText.start + Len(first), 1) <> br1 Then
                    If bSuper = True Then
                        txtRng.Characters(scr_start, Len(first) + 1).font.superscript = msoTrue
                    Else
                        txtRng.Characters(scr_start, Len(first) + 1).font.subscript = msoTrue
                    End If
                    txtRng.Characters(scr_start, Len(first)) = ""
                    Set foundText = txtRng.Find(first, scr_start - Len(first))
                    GoTo DO1   'skip finding match of script group
                End If
                
                Set foundText = txtRng.Find(br2, scr_start + Len(first + br1) - 1)
                If Not (foundText Is Nothing) Then
                    scr_end = foundText.start
                    Set tmpText = txtRng.Characters(scr_start, scr_end - scr_start + 1)
                    
                    Set foundText = tmpText.Find(first + br1, Len(first + br1))
                    While Not (foundText Is Nothing)
                        count = count + 1
                        Set foundText = tmpText.Find(first + br1, _
                            foundText.start - tmpText.start + Len(first + br1) - 1)
                    Wend
                    
                    Do While count <> 0
                        Set foundText = txtRng.Find(br2, scr_end)
                        If Not (foundText Is Nothing) Then
                            count = count - 1
                            scr_end = foundText.start
                        Else
                            Exit Do
                        End If
                    Loop
                End If
                If bSuper = True Then
                    txtRng.Characters(scr_start, scr_end - scr_start + 1).font.superscript = msoTrue
                Else
                    txtRng.Characters(scr_start, scr_end - scr_start + 1).font.subscript = msoTrue
                End If
                
                txtRng.Characters(scr_start, Len(first + br1)) = ""
                txtRng.Characters(scr_end - Len(first + br1), Len(br2)) = ""
                Set foundText = txtRng.Find(first, scr_end - Len(first + br1 + br2))
            Loop
        End If
    Next
Next

End Sub

Sub mathColor()
'
'Replace "$text$" with "text" in color specified as a <accent>
'                       in the <colorscheme> in powerpoint menu
'
Dim scr As String, cnt, shpNo As Integer
Dim sld As Slide, shp As Shape, txtRng As TextRange, foundText As TextRange

scr = "$"
'Assume the scripts start and end in one text box
'Check if the scripts are placed in pair in one text box
cnt = 0
For Each sld In Application.ActivePresentation.Slides
    shpNo = 1
    For Each shp In sld.Shapes
    If shp.HasTextFrame Then
        'count the number of scripts
        Set txtRng = shp.TextFrame.TextRange
        Set foundText = txtRng.Find(scr)
        cnt = 0
        While Not (foundText Is Nothing)
            cnt = cnt + 1
            Set foundText = txtRng.Find(scr, foundText.start + foundText.Length - 1)
        Wend
        
        'If scripts are not in pair, skip changing color
        If (cnt Mod 2) <> 0 Then
            MsgBox "No Match in the slide#" + Str(sld.SlideIndex) + ", " + "the Shape#" + Str(shpNo)
        ElseIf cnt <> 0 Then
            changeColor txtRng, scr
        End If
    End If
    shpNo = shpNo + 1
    Next
Next

End Sub

Sub changeColor(txtRng As TextRange, scr As String)
'
'scr: character embracing a string. i.e. '$'
'The color of string must be specified in <accent>
'                     in the <colorscheme> in Powerpoint menu
'
Dim foundText As TextRange, start As Integer

Set foundText = txtRng.Find(scr)
While Not (foundText Is Nothing)
    Set foundText = foundText.Replace(scr, "")
    start = foundText.start         'mark the start of the group
            
    Set foundText = txtRng.Find(scr, foundText.start - 1) 'find end of group from the next char
    If Not (foundText Is Nothing) Then
        Set foundText = foundText.Replace(scr, "")
        txtRng.Characters(start, foundText.start - start).font.Color.RGB = _
            ActivePresentation.Slides.Range.ColorScheme.Colors(ppAccent1).RGB
        'txtRng.Characters(start, foundText.start - start).font.Color.RGB = QBColor(1)
    End If
    Set foundText = txtRng.Find(scr, foundText.start + foundText.Length - 1)
Wend

End Sub

Sub lineFormatting()
Dim sld As Slide, shp As Shape
Dim txtRng As TextRange, foundText As TextRange, nextRng As TextRange

'title of section are place to the title of a slide
placeToTitle "\subsection", "{", "}"
placeToTitle "\section", "{", "}"
placeToTitle "\subsubsection", "{", "}"
placeToTitle "\chapter", "{", "}"

breakToPages (vbCrLf + vbCrLf)
breakToPages ("\\")
breakToPages ("\newline")
breakToPages ("\break")
breakToPages ("\newpage")

'replace text1
'        text2
'with text1 text2
For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(vbCrLf)
            Do While Not (foundText Is Nothing)
                    Set foundText = foundText.Replace(vbCrLf, " ")
                With foundText
                    Set foundText = txtRng.Find(vbCrLf, .start + .Length)
                End With
            Loop
        End If
    Next
Next

'items are arranged to separate lines
breakToLines "\item[", "]", msoFalse
breakToLines "\i[", "]", msoFalse
breakToLines "\item", "", msoFalse
breakToLines "\i", "", msoTrue

End Sub

Sub breakToPages(separator As String)
'
'replace text1[separator]text2
'with texts on separate slides on second slide
'
Dim sld As Slide, shp As Shape
Dim txtRng As TextRange, foundText As TextRange, nextRng As TextRange
Dim chrRng As TextRange

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(separator)
            If Not (foundText Is Nothing) Then
                Set foundText = foundText.Replace(separator, "")
                Application.ActivePresentation.Slides.Add sld.SlideIndex + 1, ppLayoutText
                Set nextRng = _
                    Application.ActivePresentation.Slides(sld.SlideIndex + 1).Shapes(2).TextFrame.TextRange
                    
                Set chrRng = txtRng.Characters(foundText.start, txtRng.Characters.count - foundText.start + 1)
                chrRng.Cut
                nextRng.Paste
                
                Set chrRng = txtRng.Characters(0, foundText.start - 1)
                chrRng.Cut
                txtRng.Delete
                txtRng.Paste
            End If
        End If
    Next
Next
End Sub

Sub breakToLines(startLine As String, endLine As String, matchWholeWord As Long)
'
'place texts start with \item , \i, \item[text], or \i[text] into separate lines
'
Dim sld As Slide, shp As Shape
Dim txtRng As TextRange, foundText As TextRange, nextRng As TextRange
Dim bbb As Boolean

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(startLine, 0, msoTrue, matchWholeWord)
            Do While Not (foundText Is Nothing)
                eraseBlanks txtRng, foundText.start + Len(startLine) 'erase blanks after the script '\item'
                
                bbb = False
                For i = 1 To txtRng.Sentences.count
                    If foundText.start = txtRng.Sentences(i).start Then
                        Set foundText = foundText.Replace(startLine, "")
                        bbb = True
                        Exit For
                    End If
                Next
                If bbb = False Then
                    Set foundText = foundText.Replace(startLine, vbCrLf)
                End If
                    
                'match end of line
                If endLine <> "" Then
                    Set foundText = txtRng.Find(endLine, foundText.start + foundText.Length - 1, _
                                            msoTrue, matchWholeWord)
                    If Not (foundText Is Nothing) Then
                        eraseBlanks txtRng, foundText.start + Len(endLine)
                        If txtRng.Characters(foundText.start + Len(endLine), Len(startLine)).Text = startLine Then
                            Set foundText = foundText.Replace(endLine, " ")
                        Else
                            Set foundText = foundText.Replace(endLine, vbCrLf)
                        End If
                    End If
                End If
                           
                With foundText
                    Set foundText = txtRng.Find(startLine, .start + .Length - 1, msoTrue, matchWholeWord)
                End With
            Loop
        End If
    Next
Next
End Sub

Sub placeToTitle(section As String, startT As String, endT As String)
'
' place the title of section into the title text box
'       [section][startT]title texts[endT]    --> title texts in title text box
'       e.g. \section{ title texts }
'
Dim sld As Slide, shp As Shape, txtRng As TextRange, foundText As TextRange
Dim nextTRng As TextRange, nextRng As TextRange
Dim chrRng As TextRange
Dim start As Integer

For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
        If shp.HasTextFrame Then
            Set txtRng = shp.TextFrame.TextRange
            Set foundText = txtRng.Find(section)
            While Not (foundText Is Nothing)
                eraseBlanks txtRng, foundText.start + Len(section)
                
                If txtRng.Characters(foundText.start + Len(section)).Text = startT Then
                    start = foundText.start 'mark the start of section
                    Set foundText = txtRng.Find(endT, foundText.start + foundText.Length - 1)
                    
                    If Not (foundText Is Nothing) Then
                        eraseBlanks txtRng, foundText.start + Len(endT)
                        idx = start + Len(section) + Len(startT)
                        
                        If start = txtRng.start Then
                            'copy and paste the contents for titlebox
                            Set chrRng = txtRng.Characters(idx, foundText.start - idx)
                            chrRng.Copy
                            sld.Shapes(1).TextFrame.TextRange.Paste
                            
                            'remove redundant characters
                            Set chrRng = txtRng.Characters(start, foundText.start)
                            chrRng.Delete
                            
                            Set foundText = txtRng.Find(section) 'continue to find next section indicator
                        Else
                            Application.ActivePresentation.Slides.Add sld.SlideIndex + 1, ppLayoutText
                            Set nextTRng = _
                                Application.ActivePresentation.Slides(sld.SlideIndex + 1).Shapes(1).TextFrame.TextRange
                            Set nextRng = _
                                Application.ActivePresentation.Slides(sld.SlideIndex + 1).Shapes(2).TextFrame.TextRange
                        
                            'cut the contents for textbox
                            Set chrRng = txtRng.Characters(foundText.start + Len(endT), _
                                    txtRng.Characters.count - (foundText.start + Len(endT)) + 1)
                            chrRng.Cut
                            nextRng.Paste
                        
                            'cut the contents for titlebox
                            Set chrRng = txtRng.Characters(idx, foundText.start - idx)
                            chrRng.Cut
                            nextTRng.Paste
                        
                            'remainder in the original slide
                            Set chrRng = txtRng.Characters(0, start - 1)
                            chrRng.Cut
                            txtRng.Delete
                            txtRng.Paste
                            
                            Set foundText = Nothing  'start again from next slide
                        End If
                    End If
                End If
            Wend
        End If
    Next
Next
End Sub

Function eraseBlanks(txtRng As TextRange, start As Integer)
'
'erase multiple blanks( newline, tab, and space)
'
Dim i As Integer
i = 0

'count the number of blanks
Do While txtRng.Characters(start + i) = vbCrLf Or _
        txtRng.Characters(start + i) = vbTab Or txtRng.Characters(start + i) = " "
        i = i + 1
Loop
        
If i = 0 Then
    Exit Function 'do nothing
Else
    txtRng.Characters(start, i).Text = ""
End If

eraseBlanks = i 'return number of characters erased

End Function
Sub generateSymbols()
'
' the macro generate the symbols for the "symbol" font to the slide#3, second text box
'
Dim tRange As TextRange

Set tRange = ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange
With tRange
    .font.name = "Symbol"
    .font.Size = 12
    For i = 0 To 400
        .Text = .Text + Str(i) + " "
        Set tRange = .InsertAfter.InsertSymbol("Symbol", i, msoTrue)
    Next
End With
End Sub