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

 

 

(Visited 89 times, 1 visits today)

Arzt f√ľr Allgemeinmedizin,¬†multiple pr√§ventivmedizinische, schulmedizinische und komplement√§re¬†Zusatzausbildungen.¬†

Wissenschaftliche Arbeit und Forschungs-Beiträge. Zahlreiche Artikel und Vorträge. 

Umfangreiche Recherchen¬†in der aktuellen medizinischen Forschung zum Zweck der Selbst-Weiterbildung und als Ged√§chtnis-St√ľtze. ¬†

Mässige Legasthenie, daher Rechtschreib- und Beistrichfehler, bitte nicht kommentieren, wer es nicht aushält bitte einfach nicht lesen
- Dr. Retzek's Youtube - Kanal mit Testimonials usw.
- neue Einträge abonnieren --> im Footer der Seite

√Ąrztekammer Disclaimer

√Ąrztekammmer Disclaimer

die Ober√∂sterreichische √Ąrztekammer moniert weite Teile diese Website als „aufdringlich, marktschreierisch und beim Laien den Eindruck medizinischer Exklusivit√§t erweckend“.

Dies ist keinesfalls beabsichtigt, die Website ist ein absichtsloses Weiterbildungsmedium von Dr. Retzek, der seine wissenschaftlichen Pubmed-Recherchen hier mit √§rztlichen Kollegen unentgeltlich teilt, wof√ľr Dr. Retzek von vielen Kollegen aus dem In- und Ausland regelm√§ssig Anerkennung ausgesprochen bekommt.

Dass Wissenschaftsrecherchen und Studien „das Standesansehen der √Ąrzte“ verletzen k√∂nnte, war Dr. Retzek nicht bewusst, er bedauert dies zutiefst und entschuldigt sich bei den betroffenen Kollegen.

 

Kommentar verfassen

Diese Website verwendet Akismet, um Spam zu reduzieren. Erfahre mehr dar√ľber, wie deine Kommentardaten verarbeitet werden.