Макрос импорта из MS Word - История изменений

WikiSysop: 1 версия

2008-10-23T16:48:09Z

1 версия

StasFomin: дополнение

2008-09-04T15:13:18Z

дополнение

WikiSysop: 1 версия

2008-08-04T09:55:52Z

1 версия

BenderBot: реплицировано из внутренней CustisWiki

2006-06-09T03:50:01Z

реплицировано из внутренней CustisWiki

Новая страница

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

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

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

<code-vb>
Option Explicit

Sub Word2MediaWiki()
Application.ScreenUpdating = False
MediaWikiEscapeChars
SplitParagraphs
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
Dim fl As Variant
Set fl = .Range.ListFormat
If IsEmpty(fl) Then
.style = ActiveDocument.styles(wdStyleNormalIndent)
End If
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
</code-vb>

[[Category:Программирование]]
[[Category:Документирование]]

{{replicate-from-custiswiki-to-lib}}

StasFomin: Bug 18156

2006-06-08T15:30:24Z

Bug 18156

BenderBot: реплицировано из внутренней CustisWiki

2006-03-29T05:44:17Z

реплицировано из внутренней CustisWiki

← Предыдущая	Версия 16:48, 23 октября 2008
(нет различий)

@@ Строка 1: / Строка 1: @@
-Этот макрос импорта (доработанный макрос от http://www.infpro.com/downloads/downloads/wordmedia.htm), пытается эвристически преобразовать MS Word разметку в текстовую разметку [[{{SITENAME}}]].
+{{warning}} Информация устарела.
 Скопируйте текст макроса в буфер обмена, перейдите в Word, откройте Редактор <tt>Visual Basic</tt> клавишами <tt>Alt-F11</tt>, вставьте текст в шаблон <tt>Normal</tt>. Сохраните шаблон, затем используйте <tt>Alt-F8</tt> для вызова и запуска макроса.
@@ Строка 465: / Строка 469: @@
 </code-vb>
-[[Category:Программирование]]
+[[Category:Архив]]
-[[Category:Документирование]]
-−
 {{replicate-from-custiswiki-to-lib}}

@@ Строка 10: / Строка 10: @@
 Sub Word2MediaWiki()
      Application.ScreenUpdating = False
      MediaWikiEscapeChars
      MediaWikiConvertHyperlinks
      MediaWikiConvertItalic
@@ Строка 404: / Строка 404: @@
                .Wrap = wdFindContinue
                Do While .Execute
-                  With Selection
+                    With Selection
-                       .style = ActiveDocument.styles(wdStyleNormalIndent)
+                       Dim fl As Variant
-                  End With
+                      Set fl = .Range.ListFormat
                Loop
           End With
@@ Строка 464: / Строка 468: @@
 [[Category:Документирование]]
+{{replicate-from-custiswiki-to-all}}
 {{replicate-from-custiswiki-to-lib}}