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
