Skip to content

Instantly share code, notes, and snippets.

@pzgz

pzgz/Word2Textile.vb

Last active September 14, 2016 20:50
Show Gist options
  • Save pzgz/1728559 to your computer and use it in GitHub Desktop.
Save pzgz/1728559 to your computer and use it in GitHub Desktop.
Download ZIP
Word2Textile
Raw
Word2Textile.vb
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment