' Word to Sycamore Wiki Markup
' original : http://www.infpro.com/downloads/downloads/wordmedia.htm
'
' Modified for use with the Project Sycamore Wiki http://projectsycamore.org
'
Sub Word2SycamoreWiki()
    Application.ScreenUpdating = False
    SycamoreWikiEscapeChars
    SycamoreWikiConvertH1
    SycamoreWikiConvertH2
    SycamoreWikiConvertH3
    SycamoreWikiConvertH4
    SycamoreWikiConvertH5
    SycamoreWikiConvertItalic
    SycamoreWikiConvertBold
    SycamoreWikiConvertUnderline
    SycamoreWikiConvertStrikeThrough
    SycamoreWikiConvertSuperscript
    SycamoreWikiConvertSubscript
    SycamoreWikiConvertLists
    SycamoreWikiConvertTables
    ' Copy to clipboard
   ActiveDocument.Content.Copy
   Application.ScreenUpdating = True
End Sub

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

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

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

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

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

Private Sub SycamoreWikiConvertBold()
    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 SycamoreWikiConvertItalic()

    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 SycamoreWikiConvertUnderline()

    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 "__"

                    .InsertAfter "__"

                End If

                

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

                .Font.Underline = False

            End With

        Loop

    End With

End Sub

 

Private Sub SycamoreWikiConvertStrikeThrough()

    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 "--X"

                    .InsertAfter "X--"

                End If

               

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

                .Font.StrikeThrough = False

            End With

        Loop

    End With

End Sub

 

Private Sub SycamoreWikiConvertSuperscript()

    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 "^"

                    .InsertAfter "^"

                End If

                

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

                .Font.Superscript = False

            End With

        Loop

    End With

End Sub

 

Private Sub SycamoreWikiConvertSubscript()

    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 ",,"

                    .InsertAfter ",,"

                End If

               

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

                .Font.Subscript = False

            End With

        Loop

    End With

End Sub

 

Private Sub SycamoreWikiConvertLists()

    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 "1."

                End If

            Next i

            .ListFormat.RemoveNumbers

        End With

    Next para

End Sub

 

Private Sub SycamoreWikiConvertTables()

    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 SycamoreWikiEscapeChars()

    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