Cacher is the code snippet organizer for pro developers

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/>
' copied from http://pastebin.com/4GUetmBd, Ref to http://www.obsidianportal.com/campaign/sydarksun/wikis/word-to-textile-conversion
'

    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