StartComputerWord2Wiki Reformat VBA

Word2Wiki Reformat VBA

-

here I found some old VBA Code for Winword that transfers Word-Files into Mediawiki / Wikipedia / Wiki – encoded files. Maybe it is of some help for someone, I gave up on writing Wiki

 

Programm
Private Function ReColorWiki(r As Range, color As Long)
Dim oRange As Range, rBefore As String, rAfter As String
Dim xColor As String
If color = 0 Then Exit Function
Set oRange = r
xColor = Right(“000000” & Hex(color), 6)
xColor = “#” & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2)
If xColor = “#000000” Then Exit Function
rBefore = “<font color=” + “””” + xColor + “””” + “>”
rAfter = “</font>”
With oRange.Find
.ClearFormatting
.Text = “”
.Format = True
.font.color = color
Flag = .Execute
While Flag = True
.Parent.font.color = 0
.Parent.InsertBefore rBefore
‘alle Formatierungen löschen, damit nicht formatiert eingefügt wird
‘Call .Parent.SetRange(Parent.End, Parent.End)
.Parent.Bold = False
.Parent.Italic = False
.Parent.Underline = wdUnderlineNone
.Parent.InsertAfter rAfter
oRange.SetRange Start:=.Parent.End, End:=oRange.End
Flag = .Execute
Wend
End With
End Function

Private Function ColorWiki(P As Paragraph)
Dim s As Long, e As Long, r As Range
Set r = P.Range
Call ReColorWiki(r, wdColorGray625)
Set r = P.Range
Call ReColorWiki(r, wdColorGray70)
Set r = P.Range
Call ReColorWiki(r, wdColorGray80)
Set r = P.Range
Call ReColorWiki(r, wdColorGray875)
Set r = P.Range
Call ReColorWiki(r, wdColorGray95)
Set r = P.Range
Call ReColorWiki(r, wdColorIndigo)
Set r = P.Range
Call ReColorWiki(r, wdColorLightBlue)
Set r = P.Range
Call ReColorWiki(r, wdColorLightOrange)
Set r = P.Range
Call ReColorWiki(r, wdColorLightYellow)
Set r = P.Range
Call ReColorWiki(r, wdColorOliveGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorPaleBlue)
Set r = P.Range
Call ReColorWiki(r, wdColorPlum)
Set r = P.Range
Call ReColorWiki(r, wdColorRed)
Set r = P.Range
Call ReColorWiki(r, wdColorRose)
Set r = P.Range
Call ReColorWiki(r, wdColorSeaGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorSkyBlue)
Set r = P.Range
Call ReColorWiki(r, wdColorTan)
Set r = P.Range
Call ReColorWiki(r, wdColorTeal)
Set r = P.Range
Call ReColorWiki(r, wdColorTurquoise)
Set r = P.Range
Call ReColorWiki(r, wdColorViolet)
Set r = P.Range
Call ReColorWiki(r, wdColorWhite)
Set r = P.Range
Call ReColorWiki(r, wdColorYellow)
Set r = P.Range
Call ReColorWiki(r, wdColorAqua)
Set r = P.Range
Call ReColorWiki(r, wdColorAutomatic)
‘set r= p.range
‘Call ReColorWiki(r, wdColorBlack)
Set r = P.Range
Call ReColorWiki(r, wdColorBlue)
Set r = P.Range
Call ReColorWiki(r, wdColorBlueGray)
Set r = P.Range
Call ReColorWiki(r, wdColorBrightGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorBrown)
Set r = P.Range
Call ReColorWiki(r, wdColorDarkBlue)
Set r = P.Range
Call ReColorWiki(r, wdColorDarkGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorDarkRed)
Set r = P.Range
Call ReColorWiki(r, wdColorDarkTeal)
Set r = P.Range
Call ReColorWiki(r, wdColorDarkYellow)
Set r = P.Range
Call ReColorWiki(r, wdColorGold)
Set r = P.Range
Call ReColorWiki(r, wdColorGray05)
Set r = P.Range
Call ReColorWiki(r, wdColorGray10)
Set r = P.Range
Call ReColorWiki(r, wdColorGray125)
Set r = P.Range
Call ReColorWiki(r, wdColorGray15)
Set r = P.Range
Call ReColorWiki(r, wdColorGray20)
Set r = P.Range
Call ReColorWiki(r, wdColorGray25)
Set r = P.Range
Call ReColorWiki(r, wdColorGray30)
Set r = P.Range
Call ReColorWiki(r, wdColorGray35)
Set r = P.Range
Call ReColorWiki(r, wdColorGray375)
Set r = P.Range
Call ReColorWiki(r, wdColorGray40)
Set r = P.Range
Call ReColorWiki(r, wdColorGray45)
Set r = P.Range
Call ReColorWiki(r, wdColorGray50)
Set r = P.Range
Call ReColorWiki(r, wdColorGray55)
Set r = P.Range
Call ReColorWiki(r, wdColorGray60)
Set r = P.Range
Call ReColorWiki(r, wdColorGray65)
Set r = P.Range
Call ReColorWiki(r, wdColorGray75)
Set r = P.Range
Call ReColorWiki(r, wdColorGray85)
Set r = P.Range
Call ReColorWiki(r, wdColorGray90)
Set r = P.Range
Call ReColorWiki(r, wdColorGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorLavender)
Set r = P.Range
Call ReColorWiki(r, wdColorLightGreen)
Set r = P.Range
Call ReColorWiki(r, wdColorLightTurquoise)
Set r = P.Range
Call ReColorWiki(r, wdColorLime)
Set r = P.Range
Call ReColorWiki(r, wdColorOrange)
Set r = P.Range
Call ReColorWiki(r, wdColorPink)
End Function

‘der Range wird nach der Farbe die in VBA-Code übergeben wird nach HTML übersetzt
‘liefert die zusätzliche Länge zurück
Private Function RecolorRange(r As Range, fColor As Long) As Long
Dim St As Long, leng As Long, s As String, xColor As String, ss As String
xColor = Right(“000000” & Hex(fColor), 6)
xColor = “#” & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2)
If xColor = “#000000” Then Exit Function
s = “<font color=” + “””” + xColor + “””” + “>”
ss = “</font>”
St = r.Start + Len(s)
leng = r.End – r.Start
r.InsertBefore (s)
r.InsertAfter (” “)
‘r.FormattedText
r.font.color = 0
i = r.End
Call r.SetRange(r.End – 1, r.End)
r.font.color = wdColorBlack
r.Bold = False
r.Italic = False
r.Underline = wdUnderlineNone
r.InsertAfter (ss)
Call r.SetRange(i – 1, i)
r.Cut
Call r.SetRange(St, St + leng)
RecolorRange = leng + Len(ss)
End Function

Private Function WikiColor(r As Range)
If r.font.color = 0 Then Exit Function
Call RecolorRange(r, r.font.color)
End Function

Private Function ReformatWiki(r As Range, ReformBold As Boolean, ReformItalian As Boolean, ReformUnderline As Boolean)
Dim oRange As Range, rBefore As String, rAfter As String
Set oRange = r
‘Tags entsprechend vor-formatieren, weil sonst Winword in unkorrekter abfolge einfügt
If ReformBold Then
rBefore = “<b>”
rAfter = “</b>”
End If
If ReformItalian Then
rBefore = rBefore + “<i>”
rAfter = “</i>” + rAfter
End If
If ReformUnderline Then
rBefore = rBefore + “<u>”
rAfter = “</u>” + rAfter
End If
‘Application.ScreenUpdating = False
With oRange.Find
.Text = “”
.Format = True
.font.Bold = ReformBold
.font.Italic = ReformItalian
If ReformUnderline Then .font.Underline = wdUnderlineSingle
Flag = .Execute
While Flag = True
.Parent.Bold = False
Call WikiColor(.Parent)
.Parent.InsertBefore rBefore
.Parent.InsertAfter rAfter
.Parent.Bold = False
.Parent.Italic = False
If ReformUnderline Then .Parent.Underline = wdUnderlineNone
oRange.SetRange Start:=.Parent.End, End:=oRange.End
Flag = .Execute
Wend
End With
End Function

Sub Word2Wiki3() ‘AbsaetzeUndUeberschriftenMitHTMLTagsVersehen()
‘Application.ScreenUpdating = False
Dim Absatz As Paragraph, oRange As Range, i As Long, bakRange As Range
Set Absatz = ActiveDocument.Paragraphs(1) ‘das ist der Text
While Not Absatz Is Nothing
Set oRange = Absatz.Range
If Not oRange.Information(wdWithInTable) Then
‘Der End-Tag soll vor und nicht hinter die Absatzmarke
oRange.SetRange Start:=oRange.Start, End:=oRange.End – 1
If Absatz.OutlineLevel = wdOutlineLevelBodyText Then ‘nun alle kombinationen durchformatieren
‘sollte besser in eigene Subprozedur aber weiss nicht wie ich den Range dauerhaft in Subfunc übergebe
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, True, True, True) ‘bold, italian, underline
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, True, True, False) ‘bold, italian
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, True, False, True) ‘bold, underline
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, False, True, True) ‘italien, underline
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, True, False, False) ‘bold
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, False, True, False) ‘italian
Set bakRange = Absatz.Range
Call ReformatWiki(bakRange, False, False, True) ‘underline
Set bakRange = Absatz.Range
Call ColorWiki(Absatz)
If Absatz.Range.ListFormat.ListValue <> 0 Then
Tag = “”
For i = 1 To Absatz.Range.ListFormat.ListLevelNumber
If Absatz.Range.ListFormat.ListType = 3 Then
Tag = Tag + “#”
Else
Tag = Tag + “*”
End If
Next
bakRange.InsertBefore Tag
Absatz.Range.ListFormat.RemoveNumbers ‘NumberType:=wdNumberParagraph
‘Absatz.Range.ListFormat.ListValue = 0
Else
bakRange.SetRange bakRange.Start, bakRange.End – 1
bakRange.InsertAfter (“<br>”)
End If
Else
Tag = “”
For i = 1 To Absatz.OutlineLevel
Tag = Tag + “=”
Next
Absatz.Range.InsertBefore Tag
oRange.InsertAfter Tag
End If
End If
Set Absatz = Absatz.Next
Wend
End Sub

Private Sub WikiFootnotes()
‘<a href=”http://michael-teut.de” class=’external’ rel=”nofollow”>http://michael-teut.de</a>
Dim r As Range, s As String, i As Long, FN As Footnote
If ActiveDocument.Footnotes.Count = 0 Then
MsgBox “Dieses Dokument enthält keinen Fussnotenbereich.”
Exit Sub
End If
For Each FN In ActiveDocument.Footnotes
i = i + 1
Set r = FN.Reference
Call r.InsertBefore(“FN_” + Chr(i))
Call FN.Range.InsertBefore(“FN_” + Chr(i))
Next
End Sub

 

Sub WordTabelleNachZweidimensionalenArray1()
Dim x() As String, r As Range, i As Long, j As Long, k As Long, l As Long, s As String
Dim oTable As Table, Zeile As Row, Zelle As Cell, strText As String
If ActiveDocument.Tables.Count = 0 Then
MsgBox “Das Dokument enthält keine Tabelle.”, vbInformation
Exit Sub
End If
Set oTable = ActiveDocument.Tables(1)
ReDim x(1 To oTable.Rows.Count, 1 To oTable.Columns.Count)
i = 0 ‘Oder auch -1, wenn der Array bei “0” beginnen soll
For Each Zeile In oTable.Rows
i = i + 1
j = 0 ‘Oder auch -1, wenn der Array bei “0” beginnen soll
For Each Zelle In Zeile.Cells
j = j + 1
strText = Zelle.Range.Text
x(i, j) = Left(strText, Len(strText) – 2)
Next Zelle
Next Zeile

Set r = ActiveDocument.Range
k = i ‘Zeilen der Tabelle
l = j ‘Spalten der Tabelle

r.InsertParagraphAfter
r.InsertAfter (“{| Border=1”)
r.InsertParagraphAfter
For k = 1 To i ‘Zeilen
For l = 1 To j ‘die Spalten
r.InsertAfter “|” + x(k, l)
r.InsertParagraphAfter
Next
r.InsertAfter “|-“
r.InsertParagraphAfter
Next
r.InsertAfter (“|}”)
r.InsertParagraphAfter
End Sub

 

 

Kommentieren Sie den Artikel

Bitte geben Sie Ihren Kommentar ein!
Bitte geben Sie hier Ihren Namen ein

×