Attribute VB_Name = "Module1"
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/bin/view/Plugins/MsWordToTWikiMLAddOn

    Application.ScreenUpdating = False
    
    CleanFormattingParagraphEndingsBold
    CleanFormattingParagraphEndingsItalic
    
    ConvertH1
    ConvertH2
    ConvertH3
    ConvertH4
    ConvertH5
    ConvertH6
    
    ConvertItalic
    ConvertBold
    
    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 <valhallasw{at}platypusnet{dot}org>
'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 '&nbsp;'
                'This is to prevent cells from being merged in twiki

                If Len(Cell.FormulaR1C1) = 0 Then Cell.FormulaR1C1 = "&nbsp;"
            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 CleanFormattingParagraphEndingsBold()
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Font.Bold = True
        .Replacement.ClearFormatting
        .Replacement.Font.Bold = False
        .Replacement.Text = "^p"
        .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 CleanFormattingParagraphEndingsItalic()
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Font.Italic = True
        .Replacement.ClearFormatting
        .Replacement.Font.Italic = False
        .Replacement.Text = "^p"
        .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 ConvertH1()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading1)
        .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 "---+ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub


Private Sub ConvertH2()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading2)
        .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 "---++ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH3()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading3)
        .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 "---+++ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH4()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading4)
        .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 "---++++ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH5()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading5)
        .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 "---+++++ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertH6()
    Dim normalStyle As Style
    Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
    
    ActiveDocument.Select
    
    With Selection.Find
    
        .ClearFormatting
        .Style = ActiveDocument.Styles(wdStyleHeading6)
        .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 "---++++++ "
                End If
                
                .Style = normalStyle
            End With
        Loop
    End With
End Sub

Private Sub ConvertBold()
'This function converts Bold text in Word to TWiki markup
'
'This function also solves the problem that if a word is in bold or
'italics, and the trailing space is also in bold/italics, then
'a space will be placed before the trailing * or _ 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
   
   Selection.Find.ClearFormatting
   
'Insert new tags
'   * find: (empty) Formatted:Bold
'   * repl: <b>^&</b> Formatted:NotBold
   With Selection.Find
        .Font.Bold = True
        .Text = ""
        .Replacement.Text = "<TWikiBold>^&</TWikiBold>"
        .Replacement.Font.Bold = False
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Remove all 'loose' formatted spaces
'   * find: <b> </b>
'   * repl: (empty) Formatting:None
    With Selection.Find
        .Text = "<TWikiBold> </TWikiBold>"
        .Replacement.Text = ""
        .Replacement.Font.Bold = False
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Remove leading spaces
'   * find: \<b\>( @)<  (with wildcards)
'   * repl: <b>
    With Selection.Find
        .Text = "\<TWikiBold\>( @)<"
        .Replacement.Text = "<TWikiBold>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Remove trailing spaces
'   * find: (>)( @)(\</b\>)  (with wildcards)
'   * repl: </b>
    With Selection.Find
        .Text = "(>)( @)(\</TWikiBold\>)"
        .Replacement.Text = "</TWikiBold>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Add missing spaces before
'   * find: (>)\<b\>  (with wildcards)
'   * repl: \1 <b>
    With Selection.Find
        .Text = "(>)\<TWikiBold\>"
        .Replacement.Text = "\1 <TWikiBold>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Add missing spaces after
'   * find: \</b\>(<)  (with wildcards)
'   * repl: </b> \1
    With Selection.Find
        .Text = "\</TWikiBold\>(<)"
        .Replacement.Text = "</TWikiBold> \1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Remove the inserted tags and replace by TWiki tags
'   * find: \<b\>(*)\</b\>   (with wildcards)
'   * repl: *\1* (Bold)
    With Selection.Find
        .Text = "\<TWikiBold\>(*)\</TWikiBold\>"
        .Replacement.Text = "*\1*"
        .Replacement.Font.Bold = False
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = True
        .MatchWholeWord = True
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub

Private Sub ConvertItalic()
'Convert Italic text in Word to TWiki markup
'
'This function also solves the problem that if a word is in bold or
'italics, and the trailing space is also in bold/italics, then
'a space will be placed before the trailing * or _ causing the
'effect to be ignored when first posted to TWiki.
'
'The function works in the same manner as ConvertItalic
   
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Font.Italic = True
        .Text = ""
        .Replacement.Text = "<TWikiItalic>^&</TWikiItalic>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.Font.Italic = False
    With Selection.Find
        .Text = "<TWikiItalic> </TWikiItalic>"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\<TWikiItalic\>( @)<"
        .Replacement.Text = "<TWikiItalic>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "(>)( @)(\</TWikiItalic\>)"
        .Replacement.Text = "</TWikiItalic>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "(>)\<TWikiItalic\>"
        .Replacement.Text = "\1 <TWikiItalic>"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "\</TWikiItalic\>(<)"
        .Replacement.Text = "</TWikiItalic> \1"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\<TWikiItalic\>(*)\</TWikiItalic\>"
        .Replacement.Text = "_\1_"
        .Replacement.Font.Italic = False
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .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 = "<img src="
        sB = "%ATTACHURL%/"
        sC = "></img>"
        'sD = sA & sB & """" & "myimage.jpg" & """" & sC
        Set fc = f.Files
        i = 1
        For Each f In fc
            If i <= ActiveDocument.InlineShapes.Count Then
                Set iShape = ActiveDocument.InlineShapes.Item(i)
                iShape.Range.InsertBefore sA & """" & sB & f.Name & """" & sC
                i = i + 1
            End If
        Next

        Shell "explorer.exe " + FileName + "_files", vbNormalFocus
    End If
End Sub