HSCWiki:Word2Wiki

BikiCrumbs: Word2Wiki

From Biki

' This is based on the Work of Gunter Schmidt and Fernando Correia. The original source was obtained from http://www.mediawiki.org/wiki/Extension:Word2MediaWikiPlus. It was modified with additional functionality by User:Me121.
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//How to Use:															//
'// 1. In MSWord open up macros (Alt+A8).											//
'// 2. Type the name Word2Wiki and then click create.										//
'// 3. Delete the code created and place the code in this file there.								//
'// 4. Click save. Then exit VBA.												//
'// 5. You can run the macro, by opening macros, selecting Word2Wiki and clicking Run.						//
'// 6. Remember, you should probably save your work before running the macro, as you cannot simply Ctrl+Z once and go back.	//
'//																//
'//What will it do?:														//
'// -Text formatted in the Heading style will be converted to wiki markup headings. Heading 1 means one =, etc.			//
'// -Bold, Italics, Underline will be unformatted and converted to wiki markup.							//
'// -SuperScript and SubScript will be converted to HTML.									//
'// -Bullets and Numbers will be converted to wiki markup.									//
'// -Tables will be converted to wiki markup.											//
'//																//
'//For help PM me121.														//
'/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub Word2Wiki()
    
    Application.ScreenUpdating = False
    
    ConvertH1
    ConvertH2
    ConvertH3
    ConvertH4
    ConvertH5
    
    ConvertItalic
    ConvertBold
    ConvertUnderline
    
    ConvertSubScript
    ConvertSuperScript
    
    ConvertLists
    ConvertTables
    
    ' Copy to clipboard
    'ActiveDocument.Content.Copy
    
    Application.ScreenUpdating = True
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 "= "
          .InsertAfter " ="
                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 "== "
          .InsertAfter " =="
                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 "=== "
                         .InsertAfter " ==="
               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 "==== "
                         .InsertAfter " ===="
               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 "===== "
                         .InsertAfter " ====="
               End If
               
               .Style = normalStyle
           End With
       Loop
   End With
End Sub
Private Sub ConvertBold()
   ActiveDocument.Select
   
   With Selection.Find
   
       .ClearFormatting
       .Font.Bold = True
       .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 ""
                   .InsertAfter ""
               End If
               
               .Font.Bold = False
           End With
       Loop
   End With
End Sub
Private Sub ConvertItalic()
   ActiveDocument.Select
   
   With Selection.Find
   
       .ClearFormatting
       .Font.Italic = True
       .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 ""
                   .InsertAfter ""
               End If
               
               .Font.Italic = False
           End With
       Loop
   End With
End Sub
Private Sub ConvertUnderline()
   ActiveDocument.Select
   
   With Selection.Find
   
       .ClearFormatting
       .Font.Underline = True
       .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 ""
                   .InsertAfter ""
               End If
               
               .Font.Underline = False
           End With
       Loop
   End With
End Sub
Private Sub ConvertSubScript()
   ActiveDocument.Select
   
   With Selection.Find
   
       .ClearFormatting
       .Font.Subscript = True
       .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 ""
                   .InsertAfter ""
               End If
               
               .Font.Subscript = False
           End With
       Loop
   End With
End Sub
Private Sub ConvertSuperScript()
   ActiveDocument.Select
   
   With Selection.Find
   
       .ClearFormatting
       .Font.Superscript = True
       .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 ""
                   .InsertAfter ""
               End If
               
               .Font.Superscript = False
           End With
       Loop
   End With
End Sub
Private Sub ConvertLists()
   Dim para As Paragraph
   For Each para In ActiveDocument.ListParagraphs
       With para.Range
           If .ListFormat.ListType = wdListBullet Then
               Select Case .ListFormat.ListLevelNumber
                   Case Is = 1
                   .InsertBefore " * "
                   
                   Case Is = 2
                   .InsertBefore " ** "
                   
                   Case Is = 3
                   .InsertBefore " *** "
                   
                   Case Is = 4
                   .InsertBefore " **** "
                   
                   'etc...
               End Select
               
           ElseIf .ListFormat.ListType = wdListListNumOnly Then
               Select Case .ListFormat.ListLevelNumber
                   Case Is = 1
                   .InsertBefore " # "
                   
                   Case Is = 2
                   .InsertBefore " ## "
                   
                   Case Is = 3
                   .InsertBefore " ### "
                   
                   Case Is = 4
                   .InsertBefore " #### "
                   
                   'etc...
               End Select
               
           Else
              ' .InsertBefore "#"
           End If
           
           .ListFormat.RemoveNumbers
       End With
   Next para
End Sub
Private Sub ConvertTables()
   Dim thisTable As Table
   Dim myCol As Word.Column
   Dim myRow As Word.Row
   Dim myCell As Word.Cell
   Dim myFrame As Word.Frame
   For Each thisTable In ActiveDocument.Tables
       With thisTable
           For Each myRow In thisTable.Rows
               For Each myCell In myRow.Cells
                   With myCell.Range
                       .InsertBefore "|"
                   End With
               Next myCell
               myRow.Range.InsertBefore "|-" & vbCrLf
           Next myRow
           .Range.InsertBefore "{| border=""1""" & vbCrLf
           .Range.InsertAfter vbCrLf & "|}"
           .ConvertToText Separator:=wdSeparateByParagraphs
       End With
   Next thisTable
   For Each myFrame In ActiveDocument.Frames
       myFrame.Delete
   Next myFrame
End Sub