Ok attachment is not working. Sorry I'm new here.
Then just copy below. In de VB editor in Word right click on the module and
add a new module and paste the text. Then export it.
======
Sub Word2Wiki()
Application.ScreenUpdating = False
ReplaceQuotes
WikiEscapeChars
WikiConvertHyperlinks
WikiConvertH1
WikiConvertH2
WikiConvertH3
WikiConvertH4
WikiConvertH5
WikiConvertItalic
WikiConvertBold
WikiConvertUnderline
WikiConvertStrikeThrough
WikiConvertSuperscript
WikiConvertSubscript
WikiConvertLists
WikiConvertTables
WikiSaveAsHTMLAndConvertImages
' Copy to clipboard
ActiveDocument.Content.Copy
Application.ScreenUpdating = True
End Sub
Private Sub WikiConvertH1()
ReplaceHeading wdStyleHeading1, "=="
End Sub
Private Sub WikiConvertH2()
ReplaceHeading wdStyleHeading2, "==="
End Sub
Private Sub WikiConvertH3()
ReplaceHeading wdStyleHeading3, "===="
End Sub
Private Sub WikiConvertH4()
ReplaceHeading wdStyleHeading4, "====="
End Sub
Private Sub WikiConvertH5()
ReplaceHeading wdStyleHeading5, "======"
End Sub
Private Sub WikiConvertBold()
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 Len(.Text) > 1 And 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 = ActiveDocument.Styles("Default Paragraph Font")
.Font.Bold = False
End With
Loop
End With
End Sub
Private Sub WikiConvertItalic()
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 Len(.Text) > 1 And 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 = ActiveDocument.Styles("Default Paragraph Font")
.Font.Italic = False
End With
Loop
End With
End Sub
Private Sub WikiConvertUnderline()
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 Len(.Text) > 1 And 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 "<u>"
.InsertAfter "</u>"
End If
.Style = ActiveDocument.Styles("Default Paragraph Font")
.Font.Underline = False
End With
Loop
End With
End Sub
Private Sub WikiConvertStrikeThrough()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.StrikeThrough = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If Len(.Text) > 1 And 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 "<strike>"
.InsertAfter "</strike>"
End If
.Style = ActiveDocument.Styles("Default Paragraph Font")
.Font.StrikeThrough = False
End With
Loop
End With
End Sub
Private Sub WikiConvertSuperscript()
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
.Text = Trim(.Text)
If Len(.Text) > 1 And 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 "<sup>"
.InsertAfter "</sup>"
End If
.Style = ActiveDocument.Styles("Default Paragraph Font")
.Font.Superscript = False
End With
Loop
End With
End Sub
Private Sub WikiConvertSubscript()
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
.Text = Trim(.Text)
If Len(.Text) > 1 And 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 "<sub>"
.InsertAfter "</sub>"
End If
.Style = ActiveDocument.Styles("Default Paragraph Font")
.Font.Subscript = False
End With
Loop
End With
End Sub
Private Sub WikiConvertLists()
Dim para As Paragraph
For Each para In ActiveDocument.ListParagraphs
With para.Range
.InsertBefore " "
For i = 1 To .ListFormat.ListLevelNumber
If .ListFormat.ListType = wdListBullet Then
.InsertBefore "*"
Else
.InsertBefore "#"
End If
Next i
.ListFormat.RemoveNumbers
End With
Next para
End Sub
Private Sub WikiConvertTables()
Dim thisTable As Table
Dim thisRow As Row
Dim thisCell As Cell
Dim ElRango As Object
For Each thisTable In ActiveDocument.Tables
With thisTable
For Each thisCell In thisTable.Range.Cells
thisCell.Range.InsertBefore "|"
Next thisCell
For Each thisRow In .Rows
thisRow.Range.InsertBefore Chr(11) & "|-" & Chr(11)
If thisRow.Index = .Rows.Count Then
'Cerramos la tabla al final
thisRow.Range.InsertAfter Chr(11) & "|}" & Chr(11)
End If
If thisRow.Index = 1 Then
thisRow.Range.InsertBefore "{| border='1'"
End If
Next thisRow
Set ElRango = .ConvertToText(Separator:="|")
With ElRango.Find
.ClearFormatting
.Text = "^p"
With .Replacement
.ClearFormatting
.Text = ""
End With
.Execute Replace:=wdReplaceAll
End With
End With
Next thisTable
End Sub
Private Sub WikiConvertHyperlinks()
Dim hyperCount As Integer
hyperCount = ActiveDocument.Hyperlinks.Count
For i = 1 To hyperCount
With ActiveDocument.Hyperlinks(1)
Dim addr As String
addr = .Address
.Delete
.Range.InsertBefore "["
.Range.InsertAfter "|" & addr & "]"
End With
Next i
End Sub
' Replace all smart quotes with their dumb equivalents
Private Sub ReplaceQuotes()
Dim quotes As Boolean
quotes = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = False
ReplaceString ChrW(8220), """"
ReplaceString ChrW(8221), """"
ReplaceString "'", "'"
ReplaceString "'", "'"
Options.AutoFormatAsYouTypeReplaceQuotes = quotes
End Sub
Private Sub WikiEscapeChars()
EscapeCharacter "*"
EscapeCharacter ""
EscapeCharacter ""
EscapeCharacter ""
EscapeCharacter "{"
EscapeCharacter "}"
EscapeCharacter "["
EscapeCharacter "]"
EscapeCharacter "~"
EscapeCharacter "^^"
EscapeCharacter "|"
End Sub
Private Function ReplaceHeading(styleHeading As String, headerPrefix As
String)
Dim normalStyle As Style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(styleHeading)
.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 headerPrefix
.InsertBefore vbCr
.InsertAfter headerPrefix
End If
.Style = normalStyle
End With
Loop
End With
End Function
Private Function EscapeCharacter(char As String)
ReplaceString char, "\" & char
End Function
Private Function ReplaceString(findStr As String, replacementStr As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = findStr
.Replacement.Text = replacementStr
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Function
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
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 "[[Afbeelding:" + f.Name &
"]]"
i = i + 1
End If
Next
Shell "explorer.exe " + FileName + "_files", vbNormalFocus
End If
End Sub
=======