DokuWiki

It's better when it's simple

Инструменты пользователя

Инструменты сайта


ru:tips:word2wiki

Word2Wiki Convertor

Преобразование содержимого документа Microsoft Word в разметку Wiki.

Это макрос Word Visual Basic, и для его использования требуется копия Microsoft Word, которая поддерживает макросы Visual Basic (Word 97 или выше).

Features

  • Убирает следующие символы: * # { } [ ] ~ ^^ | '
  • Преобразует внешние гиперссылки
  • Конвертирует H1-H6 заголовки
  • Конвертирует bold/italic/underline/strikethrough/superscript/subscript форматирование
  • Конвертирует маркированные и нумерованные списки
  • Конвертирует таблицы (исключая объединенные ячейки).
  • Изображения экспортируются, создаются все необходимые ссылки

:!: Note: Может работать некорректно с документами, которые имеют кастомные стили / шаблоны. Макрос лучше всего работает с документами, написанными в шаблоне Normal, который идет по умолчанию.

Installation

  1. Скачайте Doc2Wiki.zip архив с макросом (или перейдите на страницу форума, где прикреплен архив)
  2. Распакуйте
  3. Запустите Word
  4. Запустите Visual Basic Editor (ToolsMacroVisual Basic Editor или Alt+F11).
  5. Выберите проект Normal в панели навигации слева
  6. Импортируйте файлы макроса (go to FileImport File … и выберите файлы, которые распаковали из архива: Doc2Wiki.frm and Doc2WikiMacro.bas).
  7. Закройте Visual Basic Editor

FIXME 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.

Usage

  • Откройте документ Word, который надо конвертировать (doc или docx)
  • ЗапуститеDoc2WikiMacro: в диалоге запуска макросов (ToolsMacroMacros … or Alt+F8), выберите Doc2WikiMacro и нажмите Run.
  • Появится диалоговое окно для указания пространства имен для ресурсов (изображений и других файлов). Как правило, значение пространства имен не указывается для учета текущего пространства имен.
  • Макрос преобразует документ в разметку Wiki, создает копию документа с тем же именем, но в расширении .txt. Копия размещается в том же каталоге.
  • Скопируйте содержимое файла на соответствующую страницу Wiki и загрузите все файлы, расположенные в <file name>_images каталоге (в том же месте).

MS Word Macro for converting a Word Document

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

Issues

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

23/06/2017 Here's what I found

  • 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.

ru/tips/word2wiki.txt · Последнее изменение: 2018-11-19 15:04 — bekkerel

Если не указано иное, содержимое этой вики предоставляется на условиях следующей лицензии: CC Attribution-Share Alike 4.0 International
CC Attribution-Share Alike 4.0 International Donate Powered by PHP Valid HTML5 Valid CSS Driven by DokuWiki