Inhaltsverzeichnis
Installationsanleitung
Das unten angegebene Makro wird wie folgt in Word installiert:
- Den Quelltext in eine Textdatei einfügen und unter „word2wiki.bas“ abspeichern
- Word öffnen und mit Alt+F11 den „Microsoft Visual Basic – Editor“ öffnen
- Menü Datei > Datei importieren und „word2wiki.bas“ auswählen
- Das Visual Basic – Fenster schließen
Anwendung
- In das Word-Dokument, in dem man vorher das Makro eingefügt hat, den Text einfügen, den man konvertieren möchte und mit ALT-F8 das Marko starten
- Der Konvertierer macht jetzt seine Arbeit und kopiert auch automatisch den Wiki-Code in die Zwischenablage. (weil ja das Original überschrieben wird.)
Quellcode
Attribute VB_Name = "Word2Wiki"
'Online-HTMl to Wiki: http://diberri.dyndns.org/wikipedia/html2wiki/index.html
Sub Word2Wiki() 'Diese Routine ausführen um das aktive Dokument zu konvertieren.
Application.ScreenUpdating = False
ConvertH1
ConvertH2
ConvertH3
ConvertItalic
ConvertBold
BConvertHyperlinks 'vor Underline da da Hyperlinks in Word underline sind...
'ConvertUnderline
ConvertLists
ConvertTables
' Copy to clipboard
ActiveDocument.Content.Copy
Application.ScreenUpdating = True
End Sub
Private Sub ConvertH1()
Dim normalStyle As Style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(wdStyleHeading1)
.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 vbCrLf & "== "
.InsertAfter " =="
End If
.Style = normalStyle
End With
Selection.Move
Loop
End With
End Sub
Private Sub ConvertH2()
Dim normalStyle As Style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(wdStyleHeading2)
.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 vbCrLf & "=== "
.InsertAfter " ==="
End If
.Style = normalStyle
End With
Selection.Move
Loop
End With
End Sub
Private Sub ConvertH3()
Dim normalStyle As Style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(wdStyleHeading3)
.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 vbCrLf & "==== "
.InsertAfter " ===="
End If
.Style = normalStyle
End With
Selection.Move
Loop
End With
End Sub
Private Sub ConvertBold()
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 InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Font.Bold = False
.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
.Font.Bold = False
End With
Loop
End With
End Sub
Private Sub ConvertItalic()
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 InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Font.Italic = False
.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
.Font.Italic = False
End With
Selection.Move
Loop
End With
End Sub
Private Sub ConvertUnderline()
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 InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Font.Underline = False
.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
.Font.Underline = False
Selection.Move
End With
Loop
End With
End Sub
Private Sub ConvertLists()
Dim para As Paragraph
For Each para In ActiveDocument.ListParagraphs
With para.Range
.InsertBefore " "
For i = 1 To .ListFormat.ListLevelNumber
If .ListFormat.ListType = wdListBullet Or Asc(.ListFormat.ListString) = 63 Or Not BIsNothing(.ListFormat.ListPictureBullet) Then
.InsertBefore "*"
Else
.InsertBefore "#"
End If
Next i
.ListFormat.RemoveNumbers
End With
Next para
End Sub
Private Sub ConvertTables()
Dim oTable As Table
For Each oTable In ActiveDocument.Tables
With oTable
ReDim x(1 To oTable.Rows.Count, 1 To oTable.Columns.Count)
i = 0
For Each a In oTable.Rows
i = i + 1
j = 0
For Each b In a.Cells
j = j + 1
strText = b.Range.Text
x(i, j) = Left(strText, Len(strText) - 2)
Next b
Next a
.Range.InsertParagraphAfter
.Range.InsertAfter ("{| border=1")
.Range.InsertParagraphAfter
For k = 1 To i
For l = 1 To j
.Range.InsertAfter " || " + x(k, l)
'.Range.InsertParagraphAfter
Next
.Range.InsertParagraphAfter
.Range.InsertAfter "|-"
.Range.InsertParagraphAfter
Next
.Range.InsertAfter ("|}")
.Range.InsertParagraphAfter
End With
Next oTable
End Sub
Private Sub BConvertHyperlinks()
Dim hyp As Hyperlink
Do While ActiveDocument.Hyperlinks.Count > 0
For Each hyp In ActiveDocument.Hyperlinks
t = "" & hyp.Address & " " & hyp.TextToDisplay & ""
hyp.Range.InsertAfter t
hyp.Range.Delete
Next
Loop
End Sub
Private Function BIsNothing(ByRef Object, Optional ReturnOnError As Boolean = False) As Boolean
On Error GoTo Error_
If Object Is Nothing Then
BIsNothing = True
End If
Exit Function
Error_:
BIsNothing = ReturnOnError
End Function
Quelle
Projekt-Seite: http://en.wikipedia.org/wiki/Help:WordToWiki
Deutsche Übersetzung: http://www.gratis-wiki.com/AktiKon/index.php?title=Word_in_Wiki_Konvertieren