Word2Textile

Sub Word2Textile()
'
' Word2Textile Macro
' Macro created 7/18/11 by Jim Syler, zarquon42@aol.com
' Modified from Word2MediaWiki, <http://www.infpro.com/Word2MediaWiki.aspx>
' Textile format information available at <http://redcloth.org/hobix.com/textile/>
'

    Application.ScreenUpdating = False
    ReplaceQuotes
    'TextileEscapeChars
    TextileConvertHyperlinks
    TextileConvertH1
    TextileConvertH2
    TextileConvertH3
    TextileConvertH4
    TextileConvertH5
    TextileConvertItalic
    TextileConvertBold
    TextileConvertUnderline
    TextileConvertStrikeThrough
    TextileConvertSuperscript
    TextileConvertSubscript
    TextileConvertLists
    TextileConvertTables
    ' Copy to clipboard
   ActiveDocument.Content.Copy
   Application.ScreenUpdating = True
End Sub

Private Sub TextileConvertH1()
    ReplaceHeading wdStyleHeading1, "h1. "
End Sub

Private Sub TextileConvertH2()
    ReplaceHeading wdStyleHeading2, "h2. "
End Sub

Private Sub TextileConvertH3()
    ReplaceHeading wdStyleHeading3, "h3. "
End Sub

Private Sub TextileConvertH4()
    ReplaceHeading wdStyleHeading4, "h4. "
End Sub

Private Sub TextileConvertH5()
    ReplaceHeading wdStyleHeading5, "h5. "
End Sub

Private Sub TextileConvertBold()
    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 TextileConvertItalic()

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

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

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

                    .InsertAfter ("-")

                End If



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

                .Font.StrikeThrough = False

            End With

        Loop

    End With

End Sub



Private Sub TextileConvertSuperscript()

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

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

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

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

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


    ReplaceString "—", "--"
    'This is the em-dash symbol on the Mac.

    ReplaceString "–", " - "
    'This is the en-dash symbol on the Mac.

    ReplaceString "…", "..."
    'This is the elipsis symbol on the Mac.

    Options.AutoFormatAsYouTypeReplaceQuotes = quotes

End Sub



Private Sub TextileEscapeChars()

    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