' ############################################################### ' # DocToHtml - Word-Dokument mit HTML-Tags versehen # ' # # ' # aus Fußnoten werden links; Fußnotentext am Ende eingefügt # ' # Listen, Tabellen, Fett zu , Kursiv zu # ' # Hochkommas zu Quotes # ' # Einfügen von DTD, und -Tag # ' # # ' # DocToHtml_toc - wie oben, zusätzlich wird # ' # aus Überschriften ein Inhaltsverzeichnis erstellt # ' # # ' # Wichtig: Word-Dokument muß vorher gut strukturiert sein # ' # Überschriften und Listen auszeichnen! # ' # Um die Bilder zu extrahieren, einmal von Word als HTML # ' # abspeichern, die werden in ein extra Verzeichnis gelegt. # ' # Die img-Tags selber können nur als Platzhalter eingefügt # ' # werden, da ist Nacharbeit erforderlich. # ' # Das Einfügen von alternativen Texten fürs Web bereits # ' # im Word erleichtert die Sache (Grafik formatieren). # ' # Irmgard Schwenteck, 2006 iw @ 4haus.de # ' ############################################################### Option Explicit Public istoc As Boolean Sub AddNaviItem(navitext As String) ' Aus Überschriften Link in Navigation Dim rngbkm As Range Set rngbkm = ActiveDocument.Bookmarks("bmnavi").Range rngbkm.Text = rngbkm.Text & navitext & vbCrLf ActiveDocument.Bookmarks.Add Name:="bmnavi", Range:=rngbkm End Sub Sub AddFnItem(fntext As String) ' Bookmark in die Aufzählung am Ende hinzufügen Dim rngbkm As Range Set rngbkm = ActiveDocument.Bookmarks("bmftn").Range rngbkm.Text = fntext & vbCrLf & rngbkm.Text ActiveDocument.Bookmarks.Add Name:="bmftn", Range:=rngbkm End Sub Sub DocToHtml_toc() ' Mit Inhaltsverzeichnis istoc = True DocToHtml End Sub Sub DocToHtml() Dim r As Range, doc As Document Dim n As Long Dim h1 As Integer, h2 As Integer, h3 As Integer Dim h4 As Integer, h5 As Integer, h6 As Integer Dim a As String, navtext As String Dim p As Paragraph Dim tbl As Table, tr As Row, td As Cell Dim l As List Dim weiter As Boolean Set doc = ActiveDocument ' Entities maskieren entities Set r = doc.Range r.Collapse Direction:=wdCollapseStart r.InsertAfter vbCrLf r.Style = ActiveDocument.Styles("Standard") If istoc Then ' ggf. Bookmark setzen für Inhaltsverzeichnis Set r = doc.Paragraphs(1).Range r.Collapse Direction:=wdCollapseStart r.InsertBefore vbCrLf Set r = doc.Paragraphs(2).Range r.Collapse Direction:=wdCollapseStart ActiveDocument.Bookmarks.Add Range:=r, Name:="bmnavi" End If ' Listenelemente On Error Resume Next For Each p In doc.ListParagraphs Set r = doc.Range(p.Range.Start, p.Range.End - 1) r.InsertBefore "
  • " r.InsertAfter "
    • " Next p ' Listen For Each l In doc.Lists Set r = doc.Range(l.Range.Start, l.Range.End - 1) If l.Range.ListFormat.ListType = wdListSimpleNumbering Then r.InsertBefore "
      " r.InsertAfter vbCrLf & "
    " Else r.InsertBefore "
      " r.InsertAfter vbCrLf & "
    " End If l.RemoveNumbers Next l ' Tabellen ' wenn in der ersten Zeile das erste Zeichen fett ist, wird vorausgesetzt, ' daß es sich um die Tabellenüberschrift handelt For Each tbl In doc.Tables tbl.Rows.AllowBreakAcrossPages = False tbl.Rows.HeadingFormat = False For Each tr In tbl.Rows For Each td In tr.Cells Set r = td.Range If tr.Index = 1 And r.Characters.First.Bold = True Then r.Bold = False r.InsertBefore "" r.InsertAfter "" Else r.InsertBefore "" r.InsertAfter "" End If Next td Set r = tr.Range r.InsertBefore "" r.InsertAfter "" Next tr Set r = tbl.Range r.InsertBefore "" r.InsertAfter "
    " tbl.ConvertToText Separator:=" " Next tbl ' der Rest: Überschriften, Absätze mit ID in den Überschriften ' Aus Überschriften wird ein Inhaltsverzeichnis am Anfang ' Falls Überschriftsebenen nicht mit berücksichtigt werden sollen, ' dann die entsprechende Zeile "navtext = navtext ..." auskommentieren h1 = 0 h2 = 0 h3 = 0 h4 = 0 h5 = 0 h6 = 0 a = "k" For n = 2 To doc.Paragraphs.Count - 1 Set r = doc.Range(doc.Paragraphs(n).Range.Start, doc.Paragraphs(n).Range.End - 1) If r.Characters.First <> "<" Then If doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading1) Then h1 = h1 + 1 h2 = 0 h3 = 0 h4 = 0 h5 = 0 h6 = 0 If istoc Then a = "k" & Format(h1, "0") navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "

    " Else r.InsertBefore "

    " End If r.InsertAfter "

    " ElseIf doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading2) Then h2 = h2 + 1 h3 = 0 h4 = 0 h5 = 0 h6 = 0 If istoc Then a = "k" & Format(h1, "0") & "_" & Format(h2, "0") navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "

    " Else r.InsertBefore "

    " End If r.InsertAfter "

    " ElseIf doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading3) Then h3 = h3 + 1 h4 = 0 h5 = 0 h6 = 0 If istoc Then a = "k" & Format(h1, "0") & "_" & Format(h2, "0") & "_" & Format(h3, "0") navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "

    " Else r.InsertBefore "

    " End If r.InsertAfter "

    " ElseIf doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading4) Then h4 = h4 + 1 h5 = 0 h6 = 0 If istoc Then a = "k" & Format(h1, "0") & "_" & Format(h2, "0") & "_" & Format(h3, "0") & "_" & Format(h4, "0") navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "

    " Else r.InsertBefore "

    " End If r.InsertAfter "

    " ElseIf doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading5) Then h5 = h5 + 1 h6 = 0 a = "k" & Format(h1, "0") & "_" & Format(h2, "0") & "_" & Format(h3, "0") & "_" & Format(h4, "0") & "_" & Format(h5, "0") If istoc Then navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "
    " r.InsertAfter "
    " Else r.InsertBefore "
    " End If ElseIf doc.Paragraphs(n).Style = ActiveDocument.Styles(wdStyleHeading6) Then h6 = h6 + 1 If istoc Then a = "k" & Format(h1, "0") & "_" & Format(h2, "0") & "_" & Format(h3, "0") & "_" & Format(h4, "0") & "_" & Format(h5, "0") & "_" & Format(h6, "0") navtext = navtext & "" & r.Text & "" & vbCrLf r.InsertBefore "
    " Else r.InsertBefore "
    " End If r.InsertAfter "
    " Else r.InsertBefore "

    " r.InsertAfter "

    " End If End If Next n ' Einfügen des Inhaltsverzeichnisses If istoc Then AddNaviItem navtext ' fett zu strong Selection.HomeKey Unit:=wdStory weiter = True Do While weiter Selection.Find.ClearFormatting Selection.Find.Font.Bold = True With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute End With If Selection.Find.Found Then Set r = Selection.Range ' Ausschließen von Überschriften und einsamen Absatzende-Marken If r.Characters.First <> "<" And Len(r.Text) > 1 Then r.InsertBefore "" r.InsertAfter "" n = Selection.End Selection.Start = n Selection.End = n + 9 Selection.Range.Bold = False Selection.Collapse Direction:=wdCollapseEnd End If weiter = True Else weiter = False End If Loop ' Kursiv zu em Selection.HomeKey Unit:=wdStory weiter = True Do While weiter Selection.Find.ClearFormatting Selection.Find.Font.Italic = True With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False .Execute End With If Selection.Find.Found Then Set r = Selection.Range If r.Characters.First <> "<" Then r.InsertBefore "" r.InsertAfter "" n = Selection.End Selection.Start = n Selection.End = n + 5 Selection.Range.Italic = False Selection.Collapse Direction:=wdCollapseEnd End If weiter = True Else weiter = False End If Loop ' Manueller Zeilenumbruch zu br Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^l" .Replacement.Text = "
    ^l" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' Quotes Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = " """ .Replacement.Text = " „" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = """" .Replacement.Text = "”" .Forward = True .Wrap = wdFindStop .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' Klasse für fett formatierte Absätze Selection.Find.ClearFormatting Selection.Find.Font.Bold = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Bold = True With Selection.Find .Text = "

    " .Replacement.Text = "

    " .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll ' Fußnoten Set r = doc.Range r.Collapse Direction:=wdCollapseEnd r.InsertAfter vbCrLf Set r = doc.Range r.Collapse Direction:=wdCollapseEnd ActiveDocument.Bookmarks.Add Range:=r, Name:="bmftn" Set r = doc.Range r.Collapse Direction:=wdCollapseEnd r.InsertAfter vbCrLf FootnotesIntoText ' Bilder, können nur Platzhalter sein; manuell nachbearbeiten! images ' HTML-Gerüst Set r = doc.Range r.Collapse Direction:=wdCollapseEnd r.InsertAfter "" & vbCrLf & "" Set r = doc.Range r.Collapse Direction:=wdCollapseStart r.InsertBefore "" & vbCrLf & _ "" & vbCrLf & "" & vbCrLf & "" & vbCrLf & "" & vbCrLf End Sub Sub FootnotesIntoText() ' Fußnoten im Text bekommen gleich eine Klasse "fn" Dim i As Integer, s As String Dim fntext As String Dim rfn As Range, r As Range Dim fn As Footnote For i = ActiveDocument.Footnotes.Count To 1 Step -1 s = Format(i, "00") Set fn = ActiveDocument.Footnotes(i) Set rfn = fn.Reference fntext = fn.Range.Text rfn.Text = "[" & s & "]" fntext = "[" & s & "] " & fntext & "" AddFnItem fntext Next i End Sub Sub images() ' geht nur provisorisch, ohne width und height, Position der shapes hängt am anchor Dim i As Integer, s As String Dim r As Range Dim inl As InlineShape, sh As Shape i = 1 For Each inl In ActiveDocument.InlineShapes Set r = inl.Range r.Collapse Direction:=wdCollapseEnd s = "" & inl.AlternativeText & "" r.InsertAfter s i = i + 1 Next inl For Each sh In ActiveDocument.Shapes Set r = sh.Anchor r.Collapse Direction:=wdCollapseEnd s = "" & sh.AlternativeText & "" r.InsertAfter s i = i + 1 Next sh Selection.HomeKey Unit:=wdStory End Sub Sub entities() ' maskiert Sonderzeichen Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "&" .Replacement.Text = "&" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "<" .Replacement.Text = "<" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = ">" .Replacement.Text = ">" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "€" .Replacement.Text = "€" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub