Attribute VB_Name = "Word2TWiki"
Sub Word2TWiki()
'Attribute VB_Name = "Word2Wiki"
'This function can be used to convert a Word doc to the TWiki formatting language
'For references: http://www.twiki.org/cgi-bin/view/Plugins/MsWordToTWikiMLAddOn
Application.ScreenUpdating = False
CleanFormattingParagraphEndings
ConvertHeading "---+", wdStyleHeading1
ConvertHeading "---++", wdStyleHeading2
ConvertHeading "---+++", wdStyleHeading3
ConvertHeading "---++++", wdStyleHeading4
ConvertHeading "---+++++", wdStyleHeading5
ConvertHeading "---++++++", wdStyleHeading6
ConvertStyle "__", bold:=True, italic:=True
ConvertStyle "*", twikiCode2:="*", bold:=True, underline:=wdUnderlineSingle
ConvertStyle "==", bold:=True, fontName:="Courier New"
ConvertStyle "*", bold:=True
ConvertStyle "_", italic:=True
ConvertStyle "", twikiCode2:="", underline:=wdUnderlineSingle
ConvertStyle "=", fontName:="Courier New"
ConvertLists
ConvertHyperlinks
ConvertTables
WikiSaveAsHTMLAndConvertImages
' Copy to clipboard
ActiveDocument.Content.Copy
Application.ScreenUpdating = True
End Sub
Private Sub ConvertTables()
'This function was kindly provided by Merlijn van Deen
'on September 17, 2005
'MS Excel is used in order to handle merged cells
Dim excelapp, sheet As Object
Dim thisRow As Row
Dim thisCell As Cell
Dim myRange As Range
For Each thisTable In ActiveDocument.Tables
thisTable.Select
'Breaks don't just break TWiki tables, but also the splitting routine
'Find and remove all breaks, they break split and/or TWiki
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Text = " "
.Replacement.Font.bold = False
.Replacement.Font.italic = False
.Execute FindText:="^n", Replace:=wdReplaceAll 'column
.Execute FindText:="^m", Replace:=wdReplaceAll 'page
.Execute FindText:="^b", Replace:=wdReplaceAll 'section
End With
'Added by Jos Maccabiani on Sep 18, 2005:
'To preserve line breaks in the table, treat paragraph and line breaks in a
'special way: replace with unformatted %BR%
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Replacement.Text = " %BR% "
.Replacement.Font.bold = False
.Replacement.Font.italic = False
.Execute FindText:="^p", Replace:=wdReplaceAll 'paragraph
.Execute FindText:="^l", Replace:=wdReplaceAll 'line
End With
thisTable.Select
Selection.Copy
'use excel to fix merged cells
Set excelapp = CreateObject("Excel.Application")
excelapp.Workbooks.Add
Set sheet = excelapp.Worksheets.Add
sheet.Paste
'disable all borders, necessary to prevent extra spaces between
' | | in merged cells
excelapp.Cells.Borders.LineStyle = wdNone
For Each Cell In excelapp.Selection.Cells
'First check if the cell is empty (or contains of spaces)
'If so, change contents to ' '
'This is to prevent cells from being merged in twiki
If Len(Cell.FormulaR1C1) = 0 Then Cell.FormulaR1C1 = " "
Next
For Each Cell In excelapp.Selection.Cells
'Now unmerge-and-change all cells
Set c = Cell.Mergearea 'Cells have to be unmerged first, but the area is needed later
'nul is an output variable; VBA syntax checking needed one, even though
'Split is listed as a Method for Cell.
'This sub splits the cells in word to their original state (with information from Excel)
'! a SUB will give no output normally, however, the VBA syntax checker doesn't recognise the use of Split as a sub
'! The syntax checker will complain about adding nul = _and_ about removing it when thisTable is defined
'! The program works without defining thisTable, so just keep the nul = (or find a way to fix it)
nul = thisTable.Cell(Cell.Row, Cell.Column).Split(c.Rows.Count, c.Columns.Count)
c.UnMerge
If c.Rows.Count > 1 Then 'rows!
For x = 2 To c.Rows.Count
c.Cells(x, 1) = "^"
Next x
End If
Next
excelapp.Selection.Copy
Set myRange = thisTable.Cell(1, 1).Range
myRange.End = thisTable.Cell(thisTable.Rows.Count, thisTable.Columns.Count).Range.End
myRange.Select
'fix it, the dirty way
Selection.Paste 'replace the table with the excel data
'cleaning up
Set sheet = Nothing
excelapp.DisplayAlerts = False 'To prevent 'Do you want to save (...)' dialog of excel
excelapp.Quit
Set excelapp = Nothing
'End with the original procedure
For Each thisRow In thisTable.Rows
thisRow.Range.InsertBefore "|"
thisRow.Range.InsertAfter "|"
Next thisRow
thisTable.ConvertToText Separator:="|"
Next thisTable
End Sub
Private Sub CleanFormattingParagraphEndings()
With Selection.Find
.ClearFormatting
'Target
.Text = "^p"
'Replacement
.Replacement.ClearFormatting
.Replacement.Font.bold = False
.Replacement.Font.italic = False
.Replacement.Font.underline = wdUnderlineNone
.Replacement.Font.Name = "Arial"
.Replacement.Text = "^p"
'Options
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Private Sub ConvertHeading(twikiCode As String, heading As WdBuiltinStyle)
Dim normalStyle As style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.style = ActiveDocument.Styles(heading)
.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 twikiCode + " "
End If
.style = normalStyle
End With
Loop
End With
End Sub
Private Sub ConvertStyle(twikiCode1 As String, Optional twikiCode2 As String, Optional bold As Boolean = False, Optional italic As Boolean = False, Optional underline As WdUnderline = wdUndefined, Optional fontName As String = "")
'This function converts styled text in Word to TWiki markup
'
'This function also solves the problem that if a word is in a style,
'and the trailing space is also in that style, then
'a space will be placed before the trailing wikiCode causing the
'effect to be ignored when first posted to TWiki.
'
'This is what this function does:
'--------------------------------
'Insert new tags
'Remove all 'loose' formatted spaces
'Remove leading spaces
'Remove trailing spaces
'Add missing spaces before
'Add missing spaces after
'Remove the inserted tags and replace by TWiki tags
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
End With
'Insert new tags
' * find: (empty) Formatted:Style
' * repl: ^& Formatted:NotStyle
With Selection.Find
.Font.bold = bold
.Font.italic = italic
.Font.underline = underline
.Font.Name = fontName
.Text = ""
.Replacement.Text = "^&"
.Replacement.Font.bold = False
.Replacement.Font.italic = False
.Replacement.Font.underline = wdUnderlineNone
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Remove all 'loose' formatted spaces
' * find:
' * repl: (empty) Formatting:None
With Selection.Find
.Text = " "
.Replacement.Text = ""
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Remove leading spaces
' * find: \( @)< (with wildcards)
' * repl:
With Selection.Find
.Text = "\( @)<"
.Replacement.Text = ""
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Remove trailing spaces
' * find: (>)( @)(\) (with wildcards)
' * repl:
With Selection.Find
.Text = "(>)( @)(\)"
.Replacement.Text = ""
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Add missing spaces before
' * find: (>)\ (with wildcards)
' * repl: \1
With Selection.Find
.Text = "(>)\"
.Replacement.Text = "\1 "
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Add missing spaces after
' * find: \(<) (with wildcards)
' * repl: \1
With Selection.Find
.Text = "\(<)"
.Replacement.Text = " \1"
.Format = False
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Remove the inserted tags and replace by TWiki tags
' * find: \(*)\ (with wildcards)
' * repl: twikiCode\1twikiCode
With Selection.Find
.Text = "\(*)\"
.Replacement.Text = twikiCode1 + "\1" + IIf(twikiCode2 = "", twikiCode1, twikiCode2)
.Format = True
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Private Sub ConvertHyperlinks()
Dim hyperCount As Integer
hyperCount = ActiveDocument.Hyperlinks.Count
For i = 1 To hyperCount
With ActiveDocument.Hyperlinks(1)
Dim addr As String
addr = .Address
text2disp = .TextToDisplay
.Delete
.Range.InsertBefore "[[" & addr & "]["
.Range.InsertAfter "]]"
'.Range.InsertBefore "[["
'.Range.InsertAfter "|" & addr & "]]"
End With
Next i
End Sub
Private Sub ConvertLists()
Dim para As Paragraph
For Each para In ActiveDocument.ListParagraphs
With para.Range
If .ListFormat.ListType = wdListBullet Then
.InsertBefore " * "
Else
.InsertBefore " 1. "
End If
For x = 2 To .ListFormat.ListLevelNumber
.InsertBefore " "
Next x
.ListFormat.RemoveNumbers
End With
Next para
End Sub
Private Sub WikiSaveAsHTMLAndConvertImages()
Dim s As Shape
For Each s In ActiveDocument.Shapes
If s.Type = msoPicture Then
s.ConvertToInlineShape
End If
Next
FileName = ActiveDocument.Path + "\" + ActiveDocument.Name
FolderName = FileName + "_files"
ActiveDocument.SaveAs FileName:=FileName + ".htm", _
FileFormat:=wdFormatFilteredHTML, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FolderExists(FolderName) Then
Set f = fs.GetFolder(FolderName)
Dim iShape As InlineShape
Dim sA As String, sB As String, sC As String, sD As String
sA = "