Макрос импорта из MS Word

Этот макрос импорта (доработанный макрос от http://www.infpro.com/downloads/downloads/wordmedia.htm), пытается эвристически преобразовать MS Word разметку в текстовую разметку CustisWiki.

Скопируйте текст макроса в буфер обмена, перейдите в Word, откройте Редактор Visual Basic клавишами Alt-F11, вставьте текст в шаблон Normal. Сохраните шаблон, затем используйте Alt-F8 для вызова и запуска макроса.

Обратите внимание: макрос «разрушает» исходный документ, преобразовывая его в текстовую разметку CustisWiki, поэтому позаботьтесь о backup-е!

Option Explicit
 
Sub Word2MediaWiki()
    Application.ScreenUpdating = False
    SplitParagraphs
    MediaWikiEscapeChars
    MediaWikiConvertHyperlinks
    MediaWikiConvertItalic
    MediaWikiConvertBold
    MediaWikiConvertH1
    MediaWikiConvertH2
    MediaWikiConvertH3
    MediaWikiConvertH4
    MediaWikiConvertH5
    MediaWikiConvertUnderline
    MediaWikiConvertStrikeThrough
    MediaWikiConvertSuperscript
    MediaWikiConvertSubscript
    MediaWikiConvertLists
    MediaWikiConvertTables
    ' Copy to clipboard
   ActiveDocument.Content.Copy
   Application.ScreenUpdating = True
End Sub
 
Private Sub MediaWikiConvertH1()
    ReplaceHeading wdStyleHeading1, "="
End Sub
 
Private Sub MediaWikiConvertH2()
    ReplaceHeading wdStyleHeading2, "=="
End Sub
 
Private Sub MediaWikiConvertH3()
    ReplaceHeading wdStyleHeading3, "==="
End Sub
 
Private Sub MediaWikiConvertH4()
    ReplaceHeading wdStyleHeading4, "===="
End Sub
 
Private Sub MediaWikiConvertH5()
    ReplaceHeading wdStyleHeading5, "====="
End Sub
 
Private Sub MediaWikiConvertBold()
    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(wdStyleDefaultParagraphFont)
                .Font.Bold = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertItalic()
    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(wdStyleDefaultParagraphFont)
                .Font.Italic = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertUnderline()
    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(wdStyleDefaultParagraphFont)
                .Font.Underline = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertStrikeThrough()
    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 "-"
                    .InsertAfter "-"
                End If
 
                .style = ActiveDocument.styles(wdStyleDefaultParagraphFont)
                .Font.StrikeThrough = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertSuperscript()
    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 "^"
                    .InsertAfter "^"
                End If
                .style = ActiveDocument.styles(wdStyleDefaultParagraphFont)
                .Font.Superscript = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertSubscript()
    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 "~"
                    .InsertAfter "~"
                End If
 
                .style = ActiveDocument.styles(wdStyleDefaultParagraphFont)
                .Font.Subscript = False
            End With
        Loop
    End With
End Sub
 
Private Sub MediaWikiConvertLists()
    Dim para As Paragraph
    Dim i As Integer
    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 MediaWikiConvertTables()
    Dim thisTable As Table
    Dim aRow, aCell As Object
    For Each thisTable In ActiveDocument.Tables
        With thisTable
            For Each aRow In thisTable.Rows
                With aRow
                For Each aCell In aRow.Cells
                    With aCell
                        aCell.Range.InsertBefore "|"
                        'aCell.Range.InsertAfter "|"
                    End With
                Next aCell
                '.Range.InsertBefore "|"
                .Range.InsertAfter vbCrLf + "|-"
                End With
            Next aRow
        .Range.InsertBefore "{|" + vbCrLf
        .Range.InsertAfter vbCrLf + "|}"
        .ConvertToText "|"
        End With
    Next thisTable
End Sub
 
Private Sub MediaWikiConvertHyperlinks()
    Dim hyperCount As Integer
    Dim i 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
 
Private Sub MediaWikiEscapeChars()
    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 SplitParagraphs()
  'All wdStyleNormal -> wdStyleNormalIndent
   Dim styles As New Collection
   styles.Add (wdStylePlainText)
   styles.Add (wdStyleNormal)
   styles.Add (wdStyleBodyText)
   styles.Add (wdStyleBodyText2)
   styles.Add (wdStyleBodyText3)
   Dim style As Variant
   For Each style In styles
        ActiveDocument.Select
        With Selection.Find
              .ClearFormatting
              .style = ActiveDocument.styles(wdStyleNormal)
              .Text = ""
              .Format = True
              .MatchCase = False
              .MatchWholeWord = False
              .MatchWildcards = False
              .MatchSoundsLike = False
              .MatchAllWordForms = False
              .Forward = True
              .Wrap = wdFindContinue
              Do While .Execute
                  With Selection
                      .style = ActiveDocument.styles(wdStyleNormalIndent)
                  End With
              Loop
         End With
    Next
 
    ActiveDocument.Select
    With Selection.Find
        Dim dbCr As Variant
        dbCr = vbCr + vbCr
        .ClearFormatting
        .style = ActiveDocument.styles(wdStyleNormalIndent)
        .Text = ""
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
 
        .Forward = True
        .Wrap = wdFindContinue
 
        Do While .Execute
            With Selection
                .InsertBefore vbCr
                .style = ActiveDocument.styles(wdStyleNormal)
            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

---

Внимание! Эта статья была создана путем автоматического реплицирования из внутренней базы знаний компании Заказные Информ Системы. Любые правки этой статьи могут быть перезаписаны при следующем сеансе репликации. Если у вас есть серьезное замечание по тексту статьи, запишите его в раздел «discussion».