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