Word2 Flex Wiki

Enter a topic name to show or a new topic name to create; then press Enter

.

Summary

A VBA macro for converting Microsoft Word documents to FlexWiki format

If you have questions about it, please contact me. I'm lazy right now to write detailed howto. -- SzaMa - 2006.10.22

VBA is almost the same form word 97 to 2003, so this will probably work with all of them. You have to create a new VBA module and insert the code. You can access the VBA editor in the Tools/Macro menu. After this you should run the Word2FlexWiki macro from the same menu, and the loaded document will be converted. Be careful, if you save the document, your original formatting will be lost.

For the original macro, see the page source

hi Marcell,

i've tried this macro... ive tried converting 2 x 3 simple table... yet, the table is converted this way

ains

 ||One|Two|Three||
 ||Four|Five|Six ||

only one | in between cells... and that will not convert to a 2 x 3 table right... it will be just 2 x 1, like:

One|Two|Three

Four|Five|Six

Bug fixed, thanks for the comment. -- SzaMa - 2007.08.22.

Another bug fixed: the hyperlinks' underline is turned off before convering the format. -- SzaMa - 2007.08.25.

piep

Very nice macro, thanks!

Bug

Runtime error 4680 if document contains pictures (Word 2007 on Vista) - WilliamK - 2007.11.8

I modified the original code to support colors and images. To use, you will need to modify the SavePath const in the ConvertImages() function and change LEADwiki to the domain of your wiki.

Also, it saves the document as HTML to convert the images, so you do not have to worry about destroying your original document. It has bugs, but maybe someone with more time can fix it.

' Attribute VB_Name = "Word2FlexWiki"

        ' author: Marcell Szabo (szabomarcell _at_ t-online.hu )
        '  2005.nov.23
        ' adapted from:
        '  http://www.usemod.com/cgi-bin/wiki.pl?WordToWiki
        '  by PritishJacob adapted from a [TikiWiki] [extension] by [swythan]




        Sub Word2FlexWiki()


            ConvertImages

            For x = 1 To 9
                ConvertHeading x
            Next

            ConvertHtmlEntities
            DeleteUnderlineFromLinks


            ConvertFontColor


            For Each FontStyle In _
                        Array(Array("bold", "*", "*"), _
                               Array("italic", "_", "_"), _
                               Array("underline", "+", "+"), _
                               Array("subscript", " ~", "~ "), _
                               Array("superscript", " ^", "^ ") _
                              )
                ConvertFontStyle FontStyle(0), FontStyle(1), FontStyle(2)
            Next


            ConvertLists
            ConvertTables


        End Sub




        Private Sub DeleteUnderlineFromLinks()
            Dim thisLink As Hyperlink
            For Each thisLink In ActiveDocument.Range.Hyperlinks
                thisLink.Range.Underline = wdUnderlineNone
            Next
        End Sub

        Private Sub ConvertHtmlEntities()
            strPairs = "61619:= 61662:=> 61660:<= 61546:f"
            pairs = Split(strPairs)
            For Each strPair In pairs
                pair = Split(strPair, ":")
                ActiveDocument.Select

                With Selection.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    .Text = ChrW(pair(0))
                    .Replacement.Text = pair(1)
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                Selection.Find.Execute Replace:=wdReplaceAll




            Next

        End Sub

        Private Sub ConvertHeading(depth)
            Dim normalStyle As Style
            Set normalStyle = ActiveDocument.Styles(wdStyleNormal)




            formatstr = ""
            For x = 1 To depth
                formatstr = formatstr & "!"
            Next
            formatstr = formatstr & " "




            ActiveDocument.Select

            With Selection.Find




                .ClearFormatting
                .Style = ActiveDocument.Styles(wdStyleHeading1 + 1 - depth)
                .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 formatstr
                        End If




                        .Style = normalStyle
                    End With
                Loop
            End With
        End Sub




        Private Sub ConvertFontStyle(styleAttrib, formatStrBefore, formatStrAfter)
            ActiveDocument.Select

            With Selection.Find

                .ClearFormatting
                Select Case styleAttrib
                    Case "bold": .Font.Bold = True
                    Case "italic": .Font.Italic = True
                    Case "underline": .Font.Underline = True
                    Case "subscript": .Font.Subscript = True
                    Case "superscript": .Font.Superscript = True

                End Select
                .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 formatStrBefore
                            .InsertAfter formatStrAfter
                        End If




                        Select Case styleAttrib
                            Case "bold": .Font.Bold = False
                            Case "italic": .Font.Italic = False
                            Case "underline": .Font.Underline = False
                            Case "subscript": .Font.Subscript = False
                            Case "superscript": .Font.Superscript = False




                        End Select
                    End With
                Loop
            End With
        End Sub


        Private Sub ConvertFontColor()
            ActiveDocument.Select


            With Selection.Find


                .ClearFormatting
                Dim ColorsUsed() As Long
                ColorsUsed() = GetFontColorList()


                Dim ColorUsed As Variant
                For Each ColorUsed In ColorsUsed()


                    .Font.Color = ColorUsed
                    .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 "%" & ConvertColorToHex(ColorUsed) & "%"
                                .InsertAfter "%%"
                            End If


                            .Font.Color = WdColor.wdColorAutomatic
                        End With
                    Loop
                Next ' ColorUsed
            End With
        End Sub


        Private Function ConvertColorToHex(Color As Variant)
            Dim HexColor As String


            Dim Blue As Long, Green As Long, Red As Long
            Blue = (Color) \ (2 ^ 16)
            Green = (Color \ 256) And &HFF
            Red = Color And (&HFF)
            HexColor = "#"


            HexColor = HexColor & ColorCompToHex(Red)
            HexColor = HexColor & ColorCompToHex(Green)
            HexColor = HexColor & ColorCompToHex(Blue)


            ConvertColorToHex = HexColor
        End Function


        Private Function ColorCompToHex(ColorComp As Long)
            Dim temp As String


            temp = CStr(Hex(ColorComp))
            If Len(temp) < 2 Then
                temp = "0" & temp
            End If
            ColorCompToHex = temp
        End Function


        Private Function GetFontColorList() As Long()


            Dim CharCount As Long
            Dim idx As Long
            Dim idy As Long
            Dim ColorsUsed() As Long
            Dim ColorsUsedCount As Long
            Dim temp As Long
            Dim found As Boolean


            ActiveDocument.Select


            ColorsUsedCount = 0
            ReDim ColorsUsed(ColorsUsedCount)
            ColorsUsed(0) = 0


            CharCount = ActiveDocument.Characters.Count


            For idx = 1 To CharCount
                With ActiveDocument.Characters
                    If Not .Item(idx).Font.Color = wdColorAutomatic Then
                        temp = .Item(idx).Font.Color
                        found = False
                        For idy = 0 To ColorsUsedCount - 1
                            If ColorsUsed(idy) = temp Then
                                found = True
                            End If
                        Next idy
                        If Not found Then
                            ReDim Preserve ColorsUsed(ColorsUsedCount)
                            ColorsUsed(ColorsUsedCount) = temp
                            ColorsUsedCount = ColorsUsedCount + 1
                        End If
                    End If
                End With
            Next idx


            GetFontColorList = ColorsUsed()
        End Function






        Private Sub ConvertImages()
            Const SavePath = "\\leadweb3\content\upload\conversion\"
            Dim s As Shape
            For Each s In ActiveDocument.Shapes
                s.ConvertToInlineShape
            Next


            FileName = SavePath & ActiveDocument.Name
            FolderName = FileName + "_files"


            If StrComp(Right(ActiveDocument.Name, 4), ".htm", vbTextCompare) = 0 Then
                ActiveDocument.SaveAs FileName:=FileName, _
                    FileFormat:=wdFormatFilteredHTML, LockComments:=False, Password:="", _
                    AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
                    EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
                    :=False, SaveAsAOCELetter:=False
            Else
                ActiveDocument.SaveAs FileName:=FileName + ".htm", _
                    FileFormat:=wdFormatFilteredHTML, LockComments:=False, Password:="", _
                    AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
                    EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
                    :=False, SaveAsAOCELetter:=False
            End If


            Set fs = CreateObject("Scripting.FileSystemObject")
            If fs.FolderExists(FolderName) Then
                Set f = fs.GetFolder(FolderName)


                Dim iShape As InlineShape
                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 "http:" & Replace(Replace(Replace(FileName & "_files/", "leadweb3", "leadwiki"), "\", "/") & f.Name, " ", "%20")
                        iShape.Range.Delete
                        i = i + 1
                    End If
                Next
            End If


        End Sub




        Private Sub ConvertLists()
            Dim para As Paragraph
            For Each para In ActiveDocument.ListParagraphs
                With para.Range
                    If .ListFormat.ListType = wdListSimpleNumbering Then
                       .InsertBefore "1. "
                    Else    'could be more sophisticated :(
                        .InsertBefore "* "
                    End If




                    For x = 1 To .ListFormat.ListLevelNumber
                        .InsertBefore vbTab
                    Next




                    .ListFormat.RemoveNumbers
                End With
            Next para
        End Sub




        Private Sub ConvertTables()
            Dim thisTable As Table
            Dim thisRow As Row
            Dim tempRange As Range
            For Each thisTable In ActiveDocument.Tables
                For Each thisRow In thisTable.Rows
                    thisRow.Range.InsertBefore "||"
                    thisRow.Range.InsertAfter "||"
                Next




                Set tempRange = thisTable.ConvertToText(wdSeparateByTabs)
                tempRange.Text = Replace(Replace(tempRange.Text, vbTab, "||"), vbCrLf, "||" & vbCrLf)
            Next
        End Sub