Attribute VB_Name = "Word2TWiki"
'Attribute VB_Name = "Word2Wiki"
Dim FileName As String, FolderName As String, doctitle As String
Dim htmlFile As String

Sub Word2TWiki()
'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
Dim runtime As Single 'new
Dim tocfind As Boolean
    runtime = Timer
    Application.ScreenUpdating = False

    CleanFormattingParagraphEndings
    
    ConvertHyperlinks

    ConvertHeading vbCr + "---+", wdStyleHeading1
    ConvertHeading vbCr + "---++", wdStyleHeading2
    ConvertHeading vbCr + "---+++", wdStyleHeading3
    ConvertHeading vbCr + "---++++", wdStyleHeading4
    ConvertHeading vbCr + "---+++++", wdStyleHeading5
    ConvertHeading vbCr + "---++++++", wdStyleHeading6

    ConvertLists
    
    ConvertStyle "%YELLOW%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorYellow
    ConvertStyle "%ORANGE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorOrange
    ConvertStyle "%RED%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorRed
    ConvertStyle "%PINK%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorPink
    ConvertStyle "%PURPLE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorViolet
    ConvertStyle "%PURPLE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorPlum
    ConvertStyle "%TEAL%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorTeal
    ConvertStyle "%NAVY%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorDarkBlue
    ConvertStyle "%NAVY%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorIndigo
    ConvertStyle "%BLUE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorBlue
    ConvertStyle "%AQUA%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorAqua
    ConvertStyle "%LIME%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorLime
    ConvertStyle "%GREEN%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorGreen
    ConvertStyle "%OLIVE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorOliveGreen
    ConvertStyle "%MAROON%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorDarkRed
    ConvertStyle "%BROWN%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorBrown
    ConvertStyle "%BLACK%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorBlack
    ConvertStyle "%GRAY%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorGray50
    ConvertStyle "%SILVER%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorGray25
    ConvertStyle "%WHITE%", twikiCode2:="%ENDCOLOR%", textColor:=wdColorWhite
    
    ConvertStyle "__", bold:=True, italic:=True, addSpaces:=True
    ConvertStyle "__<u>", twikiCode2:="</u>__", bold:=True, italic:=True, underline:=wdUnderlineSingle, addSpaces:=True
    ConvertStyle "*<u>", twikiCode2:="</u>*", bold:=True, underline:=wdUnderlineSingle, addSpaces:=True
    ConvertStyle "==", bold:=True, fontName:="Courier New", addSpaces:=True

    ConvertStyle "*", bold:=True, addSpaces:=True
    ConvertStyle "_", italic:=True, addSpaces:=True
    ConvertStyle "<u>", twikiCode2:="</u>", underline:=wdUnderlineSingle, addSpaces:=True
    ConvertStyle "=", fontName:="Courier New", addSpaces:=True

    WikiSaveAsHTMLAndConvertImages
    
    ConvertTables
    ActiveDocument.Save
    ' Copy to clipboard
    ActiveDocument.Content.Copy

    Dim MyDataObj As New DataObject, GetOffClipboard As Variant
    Dim fn As Integer
    MyDataObj.GetFromClipboard
    GetOffClipboard = MyDataObj.GetText()
    fn = FreeFile
    Open FolderName & "\" & doctitle & ".txt" For Output As #fn
        Print #fn, CStr(GetOffClipboard)
    Close fn
    fn = Len(CStr(GetOffClipboard))
    Application.ScreenUpdating = True
    MsgBox "TWiki Markup is on clipboard!" & vbNewLine & _
        "Text file is also saved in image folder." '& _
        vbNewLine & vbNewLine & "Complete in " & _
        Format(Timer - runtime, "0") & "s." & " file length =" & fn
    'Shell "explorer.exe " + FileName + "_files", vbNormalFocus
End Sub

Public Function GetOffClipboard() As Variant
    Dim MyDataObj As New DataObject
    MyDataObj.GetFromClipboard
    GetOffClipboard = MyDataObj.GetText()
End Function

Private Sub ConvertTables()
'This function was modified from Merlijn van Deen <valhallasw{at}platypusnet{dot}org>
'   on September 17, 2005
'MS Excel is used in order to handle merged cells
'   and table inserted in table cell
'Changed by Charlie Mao on Jun 25 2009
Dim excelapp, sheet As Object
Dim tablectr As Integer
    tablectr = 0
    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.Cut 'copy
    
        'use excel to fix merged cells
        If tablectr = 0 Then
            'save conversion time
            Set excelapp = CreateObject("Excel.Application")
        End If
        
        excelapp.Workbooks.Add
        Set sheet = excelapp.Worksheets.Add
        sheet.Paste
        Dim celladdress As String
        Dim LastRow As Integer, LastCol As Integer
        Dim I As Integer, J As Integer, tmp, tmp1
        celladdress = excelapp.Selection.Address
        
        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
            c.UnMerge
            Dim x As Integer, y As Integer
            x = c.Rows.Count
            y = c.Columns.Count
            For I = 1 To x
                For J = 1 To y
                    If c.Cells(x, y) = "" Then
                        c.Cells(x, y) = "^"
                    End If
                Next J
            Next I
            'Multi rows and multi columns
        Next
        
        tmp = Split(celladdress, ":")
        tmp1 = Split(tmp(1), "$")
        LastRow = tmp1(2)
        LastCol = Chr_xlcol(CStr(tmp1(1)))
        tmp = ""
        For I = 1 To LastRow
            tmp = tmp & "|"
            For J = 1 To LastCol
                tmp = tmp & sheet.Cells(I, J).Value & "|"
            Next J
            tmp = tmp & vbNewLine
        Next I
    
        'fix it, the dirty way
        Selection.TypeText Text:=tmp
    
        'cleaning up
        Set sheet = Nothing
        tablectr = tablectr + 1
        If tablectr = 255 Then
            excelapp.DisplayAlerts = False 'To prevent 'Do you want to  save (...)' dialog of excel
            excelapp.Quit
            Set excelapp = CreateObject("Excel.Application")
        End If
    Next thisTable
    If tablectr > 0 Then
        excelapp.DisplayAlerts = False 'To prevent 'Do you want to  save (...)' dialog of excel
        excelapp.Quit
        Set excelapp = Nothing
    End If
End Sub

Private Function Chr_xlcol(ab As String)
Dim val As Integer
    ab = UCase(ab)
    If Len(ab) = 1 Then
        Chr_xlcol = Asc(ab) - 64
        Exit Function
    End If
Dim l1 As String, l2 As String, I As Integer, J As Integer
   l1 = Left(ab, 1)
   l2 = Right(ab, 1)
   I = Asc(l1) - 64
   J = Asc(l2) - 64
   Chr_xlcol = 26 * I + J
End Function

' Set paragraph formatting to default. This avoids formatting spanning more than one row.
Private Sub CleanFormattingParagraphEndings()
    With Selection.Find
        .ClearFormatting
        'Replacement
        .Replacement.ClearFormatting
        .Replacement.Font.bold = False
        .Replacement.Font.italic = False
        .Replacement.Font.underline = wdUnderlineNone
        .Replacement.Font.Name = "Arial"
        .Replacement.Font.color = wdColorAutomatic
        'Options
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute FindText:="^p", ReplaceWith:="^p", Replace:=wdReplaceAll
    Selection.Find.Execute FindText:="^l", ReplaceWith:=" %BR% ^l", Replace:=wdReplaceAll

    ' Convert < to &lt;
    ' Do this before anything else so that HTML tags that are generated later on are not affected
    With Selection.Find
        .Text = "<"
        .Replacement.Text = "&lt;"
        .Format = False
        .MatchWholeWord = False
        .MatchWildcards = 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 Long = wdUndefined, Optional italic As Long = wdUndefined, Optional underline As WdUnderline = wdUndefined, Optional fontName As String = "", Optional textColor As WdColor = wdUndefined, Optional addSpaces As Boolean = False)
'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: <TWikiStyle>^&</TWikiStyle> Formatted:NotStyle
    With Selection.Find
        .Font.bold = bold
        .Font.italic = italic
        .Font.underline = underline
        .Font.Name = fontName
        .Font.color = textColor
        .Text = ""
        .Replacement.Text = "<TWikiStyle>^&</TWikiStyle>"
        .Replacement.Font.bold = IIf(bold <> wdUndefined, False, wdUndefined)
        .Replacement.Font.italic = IIf(italic <> wdUndefined, False, wdUndefined)
        .Replacement.Font.underline = IIf(underline <> wdUndefined, wdUnderlineNone, wdUndefined)
        .Replacement.Font.color = IIf(textColor <> wdUndefined, wdColorAutomatic, wdUndefined)
        .Format = True
        .MatchCase = True
        .MatchWholeWord = False
        .MatchWildcards = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

'Remove all 'loose' formatted spaces
'   * find: <TWikiStyle> </TWikiStyle>
'   * repl: (empty) Formatting:None
    With Selection.Find
        .Text = "<TWikiStyle> </TWikiStyle>"
        .Replacement.Text = ""
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

'Remove leading spaces
'   * find: \<TWikiStyle\>( @)<  (with wildcards)
'   * repl: <TWikiStyle>
    With Selection.Find
        .Text = "\<TWikiStyle\>( @)<"
        .Replacement.Text = "<TWikiStyle>"
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Remove trailing spaces
'   * find: (>)( @)(\</TWikiStyle\>)  (with wildcards)
'   * repl: </TWikiStyle>
    With Selection.Find
        .Text = "(>)( @)(\</TWikiStyle\>)"
        .Replacement.Text = "</TWikiStyle>"
        .Format = False
        .MatchCase = True
        .MatchWholeWord = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'Add missing spaces before
'   * find: ([! ])\<TWikiStyle\>  (with wildcards)
'   * repl: \1 <TWikiStyle>
    If addSpaces Then
        With Selection.Find
            .Text = "([! ])\<TWikiStyle\>"
            .Replacement.Text = "\1 <TWikiStyle>"
            .Format = False
            .MatchCase = True
            .MatchWholeWord = True
            .MatchWildcards = True
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    End If
'Add missing spaces after
'   * find: \</TWikiStyle\>([! ])  (with wildcards)
'   * repl: </TWikiStyle> \1
    If addSpaces Then
        With Selection.Find
            .Text = "\</TWikiStyle\>([! ])"
            .Replacement.Text = "</TWikiStyle> \1"
            .Format = False
            .MatchCase = True
            .MatchWholeWord = True
            .MatchWildcards = True
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    End If
'Remove the inserted tags and replace by TWiki tags
'   * find: \<TWikiStyle\>(*)\</TWikiStyle\>   (with wildcards)
'   * repl: twikiCode\1twikiCode
    With Selection.Find
        .Text = "\<TWikiStyle\>(*)\</TWikiStyle\>"
        .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 I As Integer        'new
Dim text2disp As String 'new

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
Dim x As Integer 'new
    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()
'Rewrite by CharlieMao on June 24 2009 to fix image loss problem
Dim fn1 As Integer, fn2 As Integer, txt As String
Dim bodyfound As Boolean, I As Integer
    doctitle = ActiveDocument.Name
    FileName = ActiveDocument.Path + "\" + doctitle
    FolderName = FileName + "_files"
    htmlFile = FileName + ".htm" 'wdFormatFilteredHTML  wdFormatHTML
    ActiveDocument.SaveAs FileName:=htmlFile, FileFormat:= _
        wdFormatFilteredHTML, LockComments:=False, Password:="", AddToRecentFiles:=True, _
        WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
         SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
    ActiveWindow.View.Type = wdWebView
    ActiveDocument.Save
    ActiveDocument.Close
    
    'remove heading from HTML to force all images to be inlineshape.
    fn1 = FreeFile
    Open htmlFile For Input As fn1
    fn2 = FreeFile
    bodyfound = False
    Open htmlFile & "l" For Output As fn2
        Print #fn2, "<html>"
        Do While EOF(fn1) = False
            Line Input #fn1, txt
            If LCase(Left(txt, 5)) = "<body" Then
                bodyfound = True
            End If
            If bodyfound = True Then
                Print #fn2, txt
            End If
        Loop
    Close fn2
    Close fn1
    Kill (htmlFile)
    Name htmlFile & "l" As htmlFile
    Documents.Open FileName:= _
        htmlFile, ConfirmConversions:= _
        False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""

    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FolderExists(FolderName) Then
        Set f = fs.GetFolder(FolderName)
        Dim iShape As InlineShape, J As Integer

        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 "<img src=""%ATTACHURL%/" & f.Name & """ alt=""" & f.Name & """ />"
                I = I + 1
            End If
        Next
        'remove all images from file so no images to be copied to excel
        Do While ActiveDocument.InlineShapes.Count > 0
            Set iShape = ActiveDocument.InlineShapes.Item(1)
            iShape.Select
            Selection.Delete Unit:=wdCharacter, Count:=1
        Loop
    End If
End Sub