Convert Microsoft Word document content to Wiki markup.

This is a Word Visual Basic macro and for usage requires a copy of Microsoft Word that supports Visual Basic macros (Word 97 or greater).

• Escapes the following characters: * # { } [ ] ~ ^^ | '
• Converts external hyperlinks
• Converts H1-H6 headings
• Converts bold/italic/underline/strikethrough/superscript/subscript formatting
• Converts bulleted/numbered lists
• Converts standard tables (suppressed cells are not supported yet).
• Image/graphics/figures are exported and all necessary references are created

Note: May not work well with documents that have highly customized styles/templates. It works best with documents written in the default Normal template.

1. Download the Doc2Wiki.zip macro archive (or refer to this forum topic with this archive file attached)
2. Unzip it
3. Start Word
4. Bring up the Visual Basic Editor (Tools→Macro→Visual Basic Editor or Alt+F11).
5. Select Normal project name from left navigation bar
6. Import the macro files (go to File→Import File … and select the files you unzipped: Doc2Wiki.frm and Doc2WikiMacro.bas).
7. Close VBE tool

provide archive at more accessible location. Suggestion: create at Github a repository, which includes these files (binary files can added as just a file). That way people can suggest improvements easily as well.

• Open a Word document to convert it (doc or docx file)
• Run the Doc2WikiMacro macro by bringing up the Macros dialog (Tools→Macro→Macros … or Alt+F8), selecting Doc2WikiMacro and clicking Run.
• A dialog box will appear to specify the namespace for resources (images and other files). Usually, the namespace value will not be specified in order to take into account the current namespace.
• The macro converts the document to Wiki markup and places a copy of the content on the file system - the same file name but with .txt extension, located in the same directory.
• Copy and paste the content of the text file into a corresponding page from Wiki portal and uploaded all files located in <file name>_images directory (from the same location).

We have tested and may further extend the Macro. The tool seem to be mainly developed by Tania Hew 07/2008 and Extended meanwhile. We inserted the footnote conversion. To download latest Doc with Macro please visit: fcon - Word2DokuWiki (Macro).

More about this you can find here in the Wiki on: word_makro

03/02/2016 This doesn't work. Keep getting Run-time error '4680': That Property is not supported for this object

• Don't have word open in Reader view. Not just the doc you are converting but any document. This leads to an error. Just close the other windows.
• There are lines in the macro that I downloaded from http://www.fristercons.de/fcon/doku.php?id=doc2dw:start that refer to:

   .Style = ActiveDocument.Styles("Standard")

  .

• “Standard” is the style of the text. If your version of Word does not have a style called “Standard” then the macro will fail. I found on Word 2013 and after that the following works:

   .Style = ActiveDocument.Styles("Normal")

  as that style is now referred to as “Normal”.

• either create a style called Standard (eg copy the “Normal” style) or search and replace in the macro to replace “Standard” for “Normal”
• There is a similar solution hosted on Github Word2Dokuwiki which also quotes the above source as the origin of the code but doesn't have the section on tables.
• You also need to look at the links section. The Syntax uses single [ instead of double and - instead of | as the link/text separator. I've corrected it in the code below:

  macro.txt

  'Please do not delete this section
  '
  'Developed by Tania Hew 07/2008
  '
  '
  'Cancel Macro'
  Private Sub CancelButton_Click()
  YesLocation.Value = False
  NoLocation.Value = False
  Word2DokuWiki.Hide
  End Sub
   
  'Convert'
  Private Sub ConvertButton_Click()
    If YesLocation.Value = False And NoLocation.Value = False Then
      MsgBox ("Please select whether or not to replace images by a specific image location")
    Else
      Dim FileName As String
      FileName = GetFilename(ActiveDocument.Name)
   
      Application.ScreenUpdating = False
      HideRevisions
      ReplaceQuotes
      DokuWikiEscapeChars
   
  '    // 2011-06-20 by Taggic
      DokuWikiConvertFootnotes
   
      DokuWikiConvertHyperlinks
      DokuWikiConvertH1
      DokuWikiConvertH2
      DokuWikiConvertH3
      DokuWikiConvertH4
      DokuWikiConvertH5
      DokuWikiConvertItalic
      DokuWikiConvertBold
      DokuWikiConvertUnderline
      DokuWikiConvertStrikeThrough
      DokuWikiConvertSuperscript
      DokuWikiConvertSubscript
      DokuWikiConvertLists
      DokuWikiConvertTable
      UndoDokuWikiEscapeChars
      DokuWikiSaveAsHTMLAndConvertImages
      MoveJPGFilesToNewFolder
      MovePNGFilesToNewFolder
      MoveGIFFilesToNewFolder
      removeImages
      ActiveDocument.Content.Copy 'Copy to clipboard
      Application.ScreenUpdating = True
      AutoCopyToFile
      'ManualCopyToFile
   
      'CLEAN UP
      'DeleteHTMFile 'Remove HTM File'
      'DeleteHTMFolder 'Remove HTM Folder and contents'
   
      'Workaround to have original Word document open at end of conversion
  '    ActiveDocument.Close
  '    Application.Documents.Open (FileName)
   
      'Close Word to DokuWiki Converter dialog
      Word2DokuWiki.Hide
   
      MsgBox ("Word to DokuWiki Conversion complete!")
    End If
  End Sub
   
   
  Private Sub NoLocation_Click()
  ImageLocation.Locked = True
  ImageLocation.BackColor = &H8000000F
  NoLabel.Visible = True
  YesLabel.Visible = False
  End Sub
   
  Private Sub YesLocation_Click()
  ImageLocation.Locked = False
  ImageLocation.BackColor = &H80000005
  YesLabel.Visible = True
  NoLabel.Visible = False
  End Sub
   
  Private Sub HideRevisions()
      ActiveDocument.ShowRevisions = False
  End Sub
   
  Private Sub DokuWikiConvertH1()
      ReplaceHeading wdStyleHeading1, "======"
  End Sub
   
  Private Sub DokuWikiConvertH2()
      ReplaceHeading wdStyleHeading2, "====="
  End Sub
   
  Private Sub DokuWikiConvertH3()
      ReplaceHeading wdStyleHeading3, "===="
  End Sub
   
  Private Sub DokuWikiConvertH4()
          ReplaceHeading wdStyleHeading4, "==="
  End Sub
   
  Private Sub DokuWikiConvertH5()
      ReplaceHeading wdStyleHeading5, "=="
  End Sub
   
  Private Sub DokuWikiConvertH6()
      ReplaceHeading wdStyleHeading5, "="
  End Sub
   
  Private Sub DokuWikiConvertBold()
      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
                      If Not Left(.Text, 2) = "**" Then
                      .InsertBefore "**"
                      End If
                      If Not Right(.Text, 2) = "**" Then
                      .InsertAfter "**"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
   
                  .Font.Bold = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertItalic()
      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
                      If Not Left(.Text, 2) = "//" Then
                      .InsertBefore "//"
                      End If
                      If Not Right(.Text, 2) = "//" Then
                      .InsertAfter "//"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
                  .Font.Italic = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertUnderline()
      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
                      If Not Left(.Text, 2) = "__" Then
                      .InsertBefore "__"
                      End If
                      If Not Right(.Text, 2) = "__" Then
                      .InsertAfter "__"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
                  .Font.Underline = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertStrikeThrough()
      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
                      If Not Left(.Text, 2) = "<del>" Then
                      .InsertBefore "<del>"
                      End If
                      If Not Right(.Text, 2) = "</del>" Then
                      .InsertAfter "</del>"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
                  .Font.StrikeThrough = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertSuperscript()
      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
                      If Not Left(.Text, 2) = "<sup>" Then
                      .InsertBefore "<sup>"
                      End If
                      If Not Right(.Text, 2) = "</sup>" Then
                      .InsertAfter "</sup>"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
                  .Font.Superscript = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertSubscript()
      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
                      If Not Left(.Text, 2) = "<sub>" Then
                      .InsertBefore "<sub>"
                      End If
                      If Not Right(.Text, 2) = "</sub>" Then
                      .InsertAfter "</sub>"
                      End If
                  End If
   
                  .Style = ActiveDocument.Styles("Normal")
                  .Font.Subscript = False
              End With
          Loop
      End With
  End Sub
   
  Private Sub DokuWikiConvertLists()
      Dim para As Paragraph
      For Each para In ActiveDocument.ListParagraphs
          With para.Range
              .InsertBefore "  "
               If .ListFormat.ListType = wdListBullet Then
                   .InsertBefore "*"
               Else
                    .InsertBefore "-"
                End If
              For i = 1 To .ListFormat.ListLevelNumber
                     .InsertBefore "  "
             Next i
              .ListFormat.RemoveNumbers
          End With
      Next para
  End Sub
   
  '   // 2011-06-20 add by Taggic
  Private Sub DokuWikiConvertFootnotes()
      Dim footnoteCount As Integer
      footnoteCount = ActiveDocument.Footnotes.Count
      For i = 1 To footnoteCount
          With ActiveDocument.Footnotes(1)
              Dim addr As String
   
              addr = .Range.Text
   
              .Reference.InsertAfter "((" & addr & "))"
              .Delete
          End With
      Next i
  End Sub
   
   
   
  Private Sub DokuWikiConvertHyperlinks()
      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 "[[" & addr & "|"
              .Range.InsertAfter "]]"
          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 DokuWikiEscapeChars()
      EscapeCharacter "*"
      EscapeCharacter "#"
      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 Sub DokuWikiConvertTable()
    Dim TotTables As Long
    TableCellData
    Do While ActiveDocument.Tables.Count() > 0
      ActiveDocument.Tables(1).Range.Select
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = " $s$|$s$ "
        .Replacement.Text = "I"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = " $s$^^$s$ "
        .Replacement.Text = "/\"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.ClearFormatting
      Application.DefaultTableSeparator = "|"
      Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, NestedTables:=True
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "^p"
        .Replacement.Text = "|^p|"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.InsertBefore ("|")
      Selection.InsertParagraphAfter
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "^p|^p"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "$s$blank$s$"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "||"
        .Replacement.Text = "| 1 |"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      With Selection.Find
        .Text = "||"
        .Replacement.Text = "| 2 |"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "| |"
        .Replacement.Text = "| 3 |"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      With Selection.Find
        .Text = "| |"
        .Replacement.Text = "| 4 |"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Paragraphs(1).Range.Select
      Selection.Find.ClearFormatting
      Selection.Find.Replacement.ClearFormatting
      With Selection.Find
        .Text = "|"
        .Replacement.Text = "^^"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
      End With
      Selection.Find.Execute Replace:=wdReplaceAll
    Loop
  End Sub
   
  Private Sub UndoDokuWikiEscapeChars()
      UndoEscapeCharacter "*"
      UndoEscapeCharacter "#"
      UndoEscapeCharacter "_"
      UndoEscapeCharacter "-"
      UndoEscapeCharacter "+"
      UndoEscapeCharacter "{"
      UndoEscapeCharacter "}"
      UndoEscapeCharacter "["
      UndoEscapeCharacter "]"
      UndoEscapeCharacter "~"
      UndoEscapeCharacter "^^"
      UndoEscapeCharacter "|"
      UndoEscapeCharacter "'"
  End Sub
   
  Private Function EscapeCharacter(char As String)
      ReplaceString char, " $s$" & char & "$s$ "
  End Function
   
  Private Function UndoEscapeCharacter(char As String)
      ReplaceString " $s$" & char & "$s$ ", 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
   
   
   
   
   
  'begin my functions'
   
  'function to get file name path of document - full path plus file name minus file extension
  'Example if file is C:\Documents & Settings\taniah\My Documents\docname.doc, this would
  'return C:\Documents & Settings\taniah\My Documents\docname'
  Private Function GetFilename(ByVal strPath As String) As String
      GetFilename = ActiveDocument.Path & "\" & ActiveDocument.Name
   
      'Strip the .doc from the end
      GetFilename = Left(GetFilename, Len(GetFilename) - 4)
  End Function
   
  'function to get file name only of text document minus extension
  'Example if file is C:\Documents & Settings\taniah\My Documents\docname.doc, this would
  'return docname'
  Private Function GetFilenameOnly(ByVal strPath As String) As String
      Dim lngPos As Long
      Dim fName As String
   
      If (Left$(strPath, 4) <> "*.txt") And (Len(strPath) > 0) Then
        On Error GoTo LocalHandler
          'Get all characters up to .txt string
          lngPos = InStr(strPath, ".txt")
          GetFilenameOnly = Left$(strPath, lngPos - 1)
        Else
  LocalHandler:
          'Return error
          MsgBox ("There was an error retrieving file name. Please ensure that current file is a text document")
          'Application.Quit
      End If
  End Function
   
  Private Sub DokuWikiSaveAsHTMLAndConvertImages()
      Dim s As Shape
      Dim FileLocation As String
   
      For Each s In ActiveDocument.Shapes
          s.ConvertToInlineShape
      Next
   
      FileLocation = ActiveDocument.Path + "\" + ActiveDocument.Name
      FileName = GetFilename(ActiveDocument.Name)
      FolderName = FileName + "-Dateien"
   
      ActiveDocument.SaveAs FileName:=FileName + ".htm", _
                    FileFormat:=wdFormatFilteredHTML, LockComments:=False, Password:="", _
                    AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
                    EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
                    :=False, SaveAsAOCELetter:=False
   
      'Rename all the files with a Unique name
      'strDir = Dir(FileName & "-Dateien\*.jpg")
   
   
      'Ask for image location on wiki'
      Dim iShape As InlineShape
   
      If YesLocation.Value = True Then
      sLocation = ImageLocation.Text
   
                  'Put image location link in DokuWiki format for all images produced in text file'
                  Set FS = CreateObject("Scripting.FileSystemObject")
                  If FS.FolderExists(FolderName) = False Then
                      FS.CreateFolder (FolderName)
                  End If
                  If FS.FolderExists(FolderName) Then
                      Set f = FS.GetFolder(FolderName)
                      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 "{{" + sLocation + ":" + f.Name & "|}}"
                              i = i + 1
                          End If
                      Next
                  End If
   
        ElseIf NoLocation.Value = True Then
              'Go through every image that has been produced and substitute the link in the DokuWiki page
              Set FS = CreateObject("Scripting.FileSystemObject")
              If FS.FolderExists(FolderName) Then
                  Set f = FS.GetFolder(FolderName)
   
                  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 "{{: " + f.Name & " :}}"
                          i = i + 1
                      End If
                  Next
                End If
        Else
            'If Cancel was chosen, do nothing.
            'Shell "explorer.exe " + FileName + "-Dateien", vbNormalFocus
   
      End If
      'MsgBox ("HTML creation done")
  End Sub
   
  'function to move jpg files from one folder to a newly created folder
  Private Sub MoveJPGFilesToNewFolder()
      Dim FSO As Object
      Dim FromPath As String
      Dim ToPath As String
      Dim FileExt As String
      Dim FNames As String
   
      FileName = GetFilename(ActiveDocument.Name)
      FolderName = FileName + "-Dateien"
   
      FromPath = FolderName
      ToPath = FileName + " IMAGES"
   
      FileExt = "*.jpg*"
   
   
      If Right(FromPath, 1) <> "\" Then
          FromPath = FromPath & "\"
      End If
   
      JPGFNames = Dir(FromPath & FileExt)
   
      If (Len(JPGFNames) = 0) Then
          'MsgBox "No files in " & FromPath
          Exit Sub
      End If
   
      Set FSO = CreateObject("scripting.filesystemobject")
   
      If FSO.FolderExists(ToPath) = False Then
          FSO.CreateFolder (ToPath)
      End If
   
      FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
      MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
  End Sub
   
  'function to move png files from one folder to a newly created folder
  Private Sub MovePNGFilesToNewFolder()
      Dim FSO As Object
      Dim FromPath As String
      Dim ToPath As String
      Dim FileExt As String
      Dim FNames As String
   
      FileName = GetFilename(ActiveDocument.Name)
      FolderName = FileName + "-Dateien"
   
      FromPath = FolderName
      ToPath = FileName + " IMAGES"
   
      FileExt = "*.png*"
   
   
      If Right(FromPath, 1) <> "\" Then
          FromPath = FromPath & "\"
      End If
   
      PNGFNames = Dir(FromPath & FileExt)
   
      If (Len(PNGFNames) = 0) Then
          'MsgBox "No files in " & FromPath
          Exit Sub
      End If
   
      Set FSO = CreateObject("scripting.filesystemobject")
   
      If FSO.FolderExists(ToPath) = False Then
          FSO.CreateFolder (ToPath)
      End If
   
      FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
      MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
  End Sub
   
  'function to move gif files from one folder to a newly created folder
  Private Sub MoveGIFFilesToNewFolder()
      Dim FSO As Object
      Dim FromPath As String
      Dim ToPath As String
      Dim FileExt As String
      Dim FNames As String
   
      FileName = GetFilename(ActiveDocument.Name)
      FolderName = FileName + "-Dateien"
   
      FromPath = FolderName
      ToPath = FileName + " IMAGES"
   
      FileExt = "*.gif*"
   
   
      If Right(FromPath, 1) <> "\" Then
          FromPath = FromPath & "\"
      End If
   
      GIFFNames = Dir(FromPath & FileExt)
   
      If (Len(GIFFNames) = 0) Then
          'MsgBox "No files in " & FromPath
          Exit Sub
      End If
   
      Set FSO = CreateObject("scripting.filesystemobject")
   
      If FSO.FolderExists(ToPath) = False Then
          FSO.CreateFolder (ToPath)
      End If
   
      FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
      MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
  End Sub
   
  'Function to delete the HTM file created
  Private Function DeleteHTMFile()
    Dim HTMFile As String
   
    'HTM File should have same name as current document minus extension
    HTMFile = GetFilenameOnly(ActiveDocument.Name) + ".htm"
   
    'Look for specified file
    For Each HTMLDoc In Application.Documents
    If HTMLDoc.Name = HTMFile Then
      wdDoc.Close
    End If
    Next HTMLDoc
   
    'Delete File
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.deletefile (ActiveDocument.Path + "\" + HTMFile), True
  End Function
   
  'function to Delete HTML folder that is automatically created when html file is created
  Private Sub DeleteHTMFolder()
    Dim FSO As Object
     Dim FolderName As String
     Dim FileName As String
   
      Set FSO = CreateObject("scripting.filesystemobject")
   
      FileName = GetFilename(ActiveDocument.Name)
      FolderName = FileName + "-Dateien"
   
      If Right(FolderName, 1) = "\" Then
          FolderName = Left(FolderName, Len(FolderName) - 1)
      End If
   
      If FSO.FolderExists(FolderName) = False Then
          'MsgBox FolderName & " doesn't exist"
          'there were no images found in source document
          MsgBox "No images were found in source document."
          Exit Sub
      End If
   
      On Error GoTo 0
      'Delete files
      FSO.deletefile FolderName & "\*.*", True
      'Delete subfolders
      FSO.deletefolder FolderName & "\*.*", True
   
      Dir "C:\" 'This line added so that folder can be deleted without error'
      'Delete folder
      FSO.deletefolder FolderName, True
      On Error GoTo 0
   
   
  End Sub
   
  'Function to remove images from a document'
  Private Sub removeImages()
  ' enregistrée le 23/10/2006 par OLIVIER
   
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
      .Text = "^g"
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
  End Sub
   
  'Create Dokuwiki version of page using user-specified file name to store contents'
  'Function not used
  Private Sub ManualCopyToFile()
     Dim sTemp As String
   
     'retrieve clipboard text content
     sTemp = ActiveDocument.Content
   
    'Open File Save As Dialog'
     With Application.Dialogs(wdDialogFileSaveAs)
      .Name = "*.txt"
      .Show
      If Err Then
         'This code runs if the dialog was cancelled
        MsgBox "Dialog Cancelled"
        Exit Sub
      End If
    End With
  End Sub
   
   
  'automatically create text file with DokuWiki syntax of document content
  Private Sub AutoCopyToFile()
   
     Dim sTemp As String
     Dim fullDocName As String
     Dim docName As String
   
     'retrieve clipboard text content
     sTemp = ActiveDocument.Content
   
     'get full document name
     fullDocName = ActiveDocument.Name
   
   
     'get filename excluding file extension
     docName = GetFilename(fullDocName) + ".txt"
   
     'THIS SECTION CAN REPLACE SECTION BELOW IF WANT TO BE GIVEN OPTION
     'TO NOT OVERWRITE FILES
     'Dim strMsg As String
     'strMsg = "A file called " & docName & " already exists. Do you want to replace the existing " & strSaveAsName & "?"
   
     ' Check if the file already exists
     'If Dir(docName & "*") = "" Then
      'If file does not exist, save without prompting.
      'save clipboard content to a text file having same name as Word document
      'ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, FileFormat:=wdFormatText, _
      'LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
      ':="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
      'SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
      'False
     'Else
        ' If file does exist, prompt with warning message.
        ' Check value of button clicked in message box.
        'Select Case MsgBox(strMsg, vbYesNoCancel + vbExclamation)
           'Case vbYes
           ' If Yes was chosen, save and overwrite existing file.
              'On Error GoTo LocalHandler
      'save clipboard content to a text file having same name as Word document
      'ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, FileFormat:=wdFormatText, _
      'LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
      ':="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
      'SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
      'False
           'Case vbNo
           ' If No was chosen, prompt for file name
           ' using the File SaveAs dialog box.
              'With Dialogs(wdDialogFileSaveAs)
                 '.Name = "*.txt"
                 '.Show
              'End With
           'Case Else
           ' If Cancel was chosen, do nothing.
        'End Select
     'End If
   
     'Need to add code below to rename images folder so name is based on the user-provided text file name
     'END THIS SECTION
   
      On Error GoTo LocalHandler
      MsgBox ("Any existing text files will be overwritten.")
      'save clipboard content to a text file having same name as Word document
      ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, _
      LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
      :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
      SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
      False
   
  LocalHandler:
          'MsgBox ("There was an error saving the text file. ")
          'Application.Quit
   
  End Sub
   
  Private Sub TableCellData()
  Dim i As Long, oColMax As Long, oRowMax As Long, oCellCnt As Long
  Dim strColStart As String, strRowStart As String
  Dim strColEnd As String, strRowEnd As String
  Dim strMsg1 As String, strMsg2 As String, strMsg3 As String, strMsg4 As String, strMsg5
    If Application.Documents.Count Then
      With Selection
        If .Information(wdWithInTable) Then
          i = ActiveDocument.Range(0, .Tables(1).Range.End).Tables.Count
          strMsg1 = TableConfigID(i)
          oColMax = .Tables(1).Columns.Count
          oRowMax = .Tables(1).Rows.Count
          oCellCnt = .Tables(1).Range.Cells.Count
          strMsg2 = "/Max. columns: " & oColMax & "/" _
                  & "Max. rows: " & oRowMax
          strMsg3 = "Total cells: " & oCellCnt & ". "
          strColStart = alphaChar(.Information(wdStartOfRangeColumnNumber))
          strRowStart = .Information(wdStartOfRangeRowNumber)
          strColEnd = alphaChar(.Information(wdEndOfRangeColumnNumber))
          strRowEnd = .Information(wdEndOfRangeRowNumber)
          Select Case .Cells.Count
            Case Is < 2
              strMsg4 = "At cell: " & strColStart & strRowStart & ". "
              If Not .Tables(1).Uniform Then
                strMsg5 = "This table contains split or merged cells."
              End If
            Case Else
              If .Tables(1).Uniform Then
                strMsg4 = "Selection spans: " _
                         & strColStart & strRowStart & ":" & strColEnd & strRowEnd & "."
              Else
                'Stet as appropriate to suppress or report spans in tables with split or merged cells
                strMsg4 = "Table contains split/merged cells." _
                   & " The span can not be positively determined."
                'strMsg4 = "Selection spans: " & strColStart & strRowStart & ":" _
                          & strColEnd & strRowEnd & ". Span susceptible to" _
                          & " error due to split/merged cells."
                strMsg5 = ""
              End If
          End Select
          'Can use message box, status bar, or both
  '        MsgBox strMsg1 & strMsg2 & vbCr & vbCr & strMsg3 _
  '                       & vbCr & vbCr & strMsg4 & vbCr & vbCr & strMsg5, _
  '                         vbInformation + vbOKOnly, "Table Data"
          Application.StatusBar = strMsg1 & strMsg2 & "/" & strMsg3 & strMsg4 & strMsg5
        End If
      End With
    End If
  lbl_Exit:
    Exit Sub
  End Sub
   
  Function TableConfigID(ByVal i As Long) As String
  Dim TopTbl As Table, Nest1Tbl As Table, Nest2Tbl As Table
  Dim x As Long, y As Long
  Dim ttCell As Word.Cell, ntCell As Word.Cell
  Dim tmpMsg1 As String, tmpMsg2 As String, tmpMsg3 As String
    Set TopTbl = ActiveDocument.Tables(i)
    tmpMsg1 = "Table " & i
    x = 0
    For Each ttCell In TopTbl.Range.Cells
      If ttCell.Tables.Count > 0 Then
        For Each Nest1Tbl In ttCell.Tables
          x = x + 1
          If Selection.InRange(Nest1Tbl.Range) Then
            tmpMsg1 = "Table " & i & "{Table " & x & "}"
          End If
          y = 0
          For Each ntCell In Nest1Tbl.Range.Cells
            If ntCell.Tables.Count > 0 Then
              For Each Nest2Tbl In ntCell.Tables
                y = y + 1
                If Selection.InRange(Nest2Tbl.Range) Then
                  tmpMsg1 = "Table " & i & "{Table " & x & "{Table " & y & "}}"
                End If
              Next Nest2Tbl
            End If
          Next ntCell
        Next Nest1Tbl
      End If
    Next ttCell
    TableConfigID = tmpMsg1
  lbl_Exit:
    Exit Function
  End Function
   
  Function alphaChar(pAribicNum As Integer) As String
    Select Case pAribicNum
      Case Is < 27
        alphaChar = String(1, (pAribicNum + 64))
      Case Is < 53
        alphaChar = "A" & String(1, (pAribicNum - (26) + 64))
     Case Is >= 53
        alphaChar = "B" & String(1, (pAribicNum - (52) + 64))
    End Select
  lbl_Exit:
    Exit Function
  End Function

  but I did not correct the issues with the table conversion. It still doesn't span columns or rows or attempt justification of the contents.

8/30/2016 Zip file download does not exist at current link on page.