Sub Word2MediaWiki()
    Application.ScreenUpdating = False
    ReplaceQuotes
    MediaWikiEscapeChars
    MediaWikiConvertHyperlinks 
    MediaWikiConvertH1
    MediaWikiConvertH2
    MediaWikiConvertH3
    MediaWikiConvertH4
    MediaWikiConvertH5
    MediaWikiConvertItalic
    MediaWikiConvertBold
    MediaWikiConvertUnderline
    MediaWikiConvertStrikeThrough
    MediaWikiConvertSuperscript
    MediaWikiConvertSubscript
    MediaWikiConvertLists
    MediaWikiConvertTables
    ' Copy to clipboard
   ActiveDocument.Content.Copy
   Application.ScreenUpdating = True
End Sub

Private Sub MediaWikiConvertH1()
    ReplaceHeading wdStyleHeading1, "="
End Sub

Private Sub MediaWikiConvertH2()
    ReplaceHeading wdStyleHeading2, "=="
End Sub

Private Sub MediaWikiConvertH3()
    ReplaceHeading wdStyleHeading3, "==="
End Sub 

Private Sub MediaWikiConvertH4()
	ReplaceHeading wdStyleHeading4, "===="
End Sub

Private Sub MediaWikiConvertH5()
    ReplaceHeading wdStyleHeading5, "====="
End Sub

Private Sub MediaWikiConvertBold()
    ActiveDocument.Select
    With Selection.Find

   

        .ClearFormatting

        .Font.Bold = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                      

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore "'''"

                    .InsertAfter "'''"

                End If

               

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.Bold = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertItalic()

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Font.Italic = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                      

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore "''"

                    .InsertAfter "''"

                End If

               

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.Italic = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertUnderline()

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Font.Underline = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                       

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore "<u>"

                    .InsertAfter "</u>"

                End If

                

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.Underline = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertStrikeThrough()

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Font.StrikeThrough = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                      

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore("<s>")

                    .InsertAfter("</s>")

                End If

               

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.StrikeThrough = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertSuperscript()

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Font.Superscript = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                .Text = Trim(.Text)

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                       

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore("<sup>")

                    .InsertAfter("</sup>")

                End If

                

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.Superscript = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertSubscript()

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Font.Subscript = True

        .Text = ""

       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                .Text = Trim(.Text)

                If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                       

                ' Don't bother to markup newline characters (prevents a loop, as well)

                If Not .Text = vbCr Then

                    .InsertBefore("<sub>")

                    .InsertAfter("</sub>")

                End If

               

                .Style = ActiveDocument.Styles("Default Paragraph Font")

                .Font.Subscript = False

            End With

        Loop

    End With

End Sub

 

Private Sub MediaWikiConvertLists()

    Dim para As Paragraph

    For Each para In ActiveDocument.ListParagraphs

        With para.Range

            .InsertBefore " "

            For i = 1 To .ListFormat.ListLevelNumber

                If .ListFormat.ListType = wdListBullet Then

                    .InsertBefore "*"

                Else

                    .InsertBefore "#"

                End If

            Next i

            .ListFormat.RemoveNumbers

        End With

    Next para

End Sub

 

Private Sub MediaWikiConvertTables()

    Dim thisTable As Table

    For Each thisTable In ActiveDocument.Tables

        With thisTable

            For Each aRow In thisTable.Rows

                With aRow

                For Each aCell In aRow.Cells

                    With aCell

                        aCell.Range.InsertBefore "|"

                        'aCell.Range.InsertAfter "|"

                    End With

                Next aCell

                '.Range.InsertBefore "|"

                .Range.InsertAfter vbCrLf + "|-"

                End With

            Next aRow

        .Range.InsertBefore "{|" + vbCrLf

        .Range.InsertAfter vbCrLf + "|}"

        .ConvertToText "|"

        End With

    Next thisTable

End Sub

 

Private Sub MediaWikiConvertHyperlinks()

    Dim hyperCount As Integer

   

    hyperCount = ActiveDocument.Hyperlinks.Count

   

    For i = 1 To hyperCount

        With ActiveDocument.Hyperlinks(1)

            Dim addr As String

            addr = .Address

            .Delete

            .Range.InsertBefore "["

            .Range.InsertAfter "-" & addr & "]"

        End With

    Next i

End Sub

 

' Replace all smart quotes with their dumb equivalents

Private Sub ReplaceQuotes()

    Dim quotes As Boolean

    quotes = Options.AutoFormatAsYouTypeReplaceQuotes

    Options.AutoFormatAsYouTypeReplaceQuotes = False

    ReplaceString ChrW(8220), """"

    ReplaceString ChrW(8221), """"

    ReplaceString "‘", "'"

    ReplaceString "’", "'"

    Options.AutoFormatAsYouTypeReplaceQuotes = quotes

End Sub

 

Private Sub MediaWikiEscapeChars()

    EscapeCharacter "*"

    EscapeCharacter "#"

    'EscapeCharacter "_"

    'EscapeCharacter "-"

    'EscapeCharacter "+"

    EscapeCharacter "{"

    EscapeCharacter "}"

    EscapeCharacter "["

    EscapeCharacter "]"

    EscapeCharacter "~"

    EscapeCharacter "^^"

    EscapeCharacter "|"

    EscapeCharacter "'"

End Sub

 

Private Function ReplaceHeading(styleHeading As String, headerPrefix As String)

    Dim normalStyle As Style

    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)

   

    ActiveDocument.Select

   

    With Selection.Find

   

        .ClearFormatting

        .Style = ActiveDocument.Styles(styleHeading)

        .Text = ""


       

        .Format = True

        .MatchCase = False

        .MatchWholeWord = False

        .MatchWildcards = False

        .MatchSoundsLike = False

        .MatchAllWordForms = False

       

        .Forward = True

        .Wrap = wdFindContinue

       

        Do While .Execute

            With Selection

                If InStr(1, .Text, vbCr) Then

                    ' Just process the chunk before any newline characters

                    ' We'll pick-up the rest with the next search

                    .Collapse

                    .MoveEndUntil vbCr

                End If

                                       

                ' Don't bother to markup newline characters (prevents a loop, as well)
                If Not .Text = vbCr Then
                    .InsertBefore headerPrefix
                    .InsertBefore vbCr
                    .InsertAfter headerPrefix
                End If
                .Style = normalStyle
            End With
        Loop
    End With
End Function

Private Function EscapeCharacter(char As String)
    ReplaceString char, "\" & char
End Function

Private Function ReplaceString(findStr As String, replacementStr As String)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = findStr
        .Replacement.Text = replacementStr
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Function