Der folgende Quelltext des MS-Word Makros WordToTEI mag vielleicht für vergleichbare Anwendungen nützlich sein:
Sub WordToTEI() ' -------------------------------------------------------------------- ' HGK Druckformatvorlagen in TEI-Tags umwandeln ' Angelegt 29.11.99 Heinz Werner Kramski ' Geaendert: ' - 30.11.99 Kra.: vervollstaendigt, Schachtelungen korrigiert ' - 11.01.00 Kra.: typographische Unterstreichung nach "aussen" ' - 12.01.00 Kra.: Reste von "TEI full" korrigiert zu "TEI lite" ' - 27.06.00 Kra.: Aenderungen nach Tagging-Tabelle vom 27.6.00 ' - 28.06.00 Kra.: revisionDesc korrekt erzeugt ' - 29.06.00 Kra.: Aenderungen nach Tagging-Tabelle vom 29.6.00 (rs statt name) etc. ' - 30.06.00 Kra.: Kleinigkeiten ' - 04.07.00 Kra.: TEI-Header nicht mehr als Textbaustein; ' Pruefung, ob Styles vorhanden sind; ' - 09.07.00 Kra.: Code optimiert; hgkdiary.dtd statt teixlite.dtd; ' Monat wieder explizit als <div>; ' Jahr nun nicht mehr pro Datei (war logisch falsch) ' - 20.07.00 Kra.: Warnung, wenn Bilder enthalten sind ' (klappt nicht!, vgl. 1891_09.doc) ' - 24.07.00 Kra.: Platzhalter fuer Abbildungen als <figure> mit Dummy-Graphik ' - 27.07.00 Kra.: Fehlerbehebung: Tags wieder in Standardschrift ' - 02.08.00 Kra.: Wochentag ermitteln, Header fuer Tageseintraege erzeugen etc. ' - 11.08.00 Kra.: DTD-Pfade etc. angepasst ' - 12.08.00 Kra.: xml:space="preserve" fuer TEI.2 eingefuegt ' - 15.08.00 Kra.: Umstellung auf XSL-Stylesheet (CSS wird von XM2 implizit weiter ' verwendet. ' - 06.04.01 Kra.: doppelte (typographische) Anfuehrungszeichen in <q>...</q> ' Druckformat "Grossbuchstaben" in echte Grossbuchstaben umwandeln ' Akut-Akzente (die als Apostroph verwendet wurden) in "'" umwandeln ' - 12.04.01 Kra.: <q>...</q>-Umwandlung deaktiviert ' - 18.04.01 Kra.: Fehlerbehebung: 1. Auftreten von Druckformat "Grossbuchstaben" ' wurde nicht behandelt ' ' ToDO: ' - vh. Abbildungen korrekt konvertieren (warum werden die nicht erkannt?) ' ' Siehe auch: ' - hgkdiary.css ' ' Bemerkungen: ' - Kombinationen aus Zeichenformaten wie unterstrichen, hochgestellt mit ' Formatvorlagen wie Personen sind problematisch: Tags *muessen* hier ' mit "Standard"-Formatierung eingefuegt werden, sonst gibt es anderswo ' Schachtelungsprobleme. <hi rend="sup">...</hi> o.ae. spaltet so aber ' eine umgebende Auszeichung auf. ' -------------------------------------------------------------------- '--------------------------------------------------------------------- ' Initialisierung '--------------------------------------------------------------------- Dim ThisMacro As String ThisMacro = "WordToTEI Version 2001/04/18/01" StatusBar = ThisMacro & " startet..." Dim Rc, FirstDay, BadDate As Boolean Dim YearStr, MonthStr, DayStr, RevDesc, TranscrStyle As String Dim Year, Month, Day As Integer Dim MonthName(12), DayName(7) As String MonthName(1) = "Januar" MonthName(2) = "Februar" MonthName(3) = "März" MonthName(4) = "April" MonthName(5) = "Mai" MonthName(6) = "Juni" MonthName(7) = "Juli" MonthName(8) = "August" MonthName(9) = "September" MonthName(10) = "Oktober" MonthName(11) = "November" MonthName(12) = "Dezember" DayName(1) = "Sonntag" DayName(2) = "Montag" DayName(3) = "Dienstag" DayName(4) = "Mittwoch" DayName(5) = "Donnerstag" DayName(6) = "Freitag" DayName(7) = "Samstag" ' vorlaeufig fuer Header, s.a. Normdatum YearStr = Left(ActiveDocument.Name, 4) MonthStr = Mid(ActiveDocument.Name, 6, 2) Year = Val(YearStr) Month = Val(MonthStr) If (Year < 1880 Or Year > 1937) Then MsgBox "Merkwürdiges Tagebuchjahr (lt. Dateiname): " & YearStr, vbExclamation, "Warnung" YearStr = "0000" Year = 0 End If If (Month < 1 Or Month > 12) Then MsgBox "Merkwürdiger Tagebuchmonat (lt. Dateiname): " & MonthStr, vbExclamation, "Warnung" MonthStr = "00" Month = 0 End If FirstDay = True '--------------------------------------------------------------------- ' Startaktionen '--------------------------------------------------------------------- Application.ScreenUpdating = False ' Tabelle der Aenderungen umwandeln StatusBar = "Erzeuge <revisionDesc>..." RevDesc = " <revisionDesc>" & Chr(13) Selection.HomeKey Unit:=wdStory If Selection.Tables.Count > 0 Then Selection.Tables(1).Select If Selection.Tables(1).Rows(1).Cells.Count = 3 Then For Each Row In Selection.Tables(1).Rows RevDesc = RevDesc & " <change>" & Chr(13) RevDesc = RevDesc & " <date>" & Left(Row.Cells(3), Len(Row.Cells(3)) - 2) & _ "</date>" & Chr(13) RevDesc = RevDesc & " <respStmt><name>" & Left(Row.Cells(2), _ Len(Row.Cells(2)) - 2) & "</name></respStmt>" & Chr(13) RevDesc = RevDesc & " <item>" & Left(Row.Cells(1), Len(Row.Cells(1)) - 2) & _ "</item>" & Chr(13) RevDesc = RevDesc & " </change>" & Chr(13) Next Row End If Selection.Rows.Delete End If ' Uns selber eintragen (s.a. weiter unten) RevDesc = RevDesc & " <change>" & Chr(13) RevDesc = RevDesc & " <date>" & Date & " " & Time & "</date>" & Chr(13) RevDesc = RevDesc & " <respStmt><name>" & ThisMacro & "</name></respStmt>" & Chr(13) RevDesc = RevDesc & " <item>" & "Konvertierung nach XML aus " & ActiveDocument.FullName & _ "</item>" & Chr(13) RevDesc = RevDesc & " </change>" & Chr(13) RevDesc = RevDesc & " </revisionDesc>" & Chr(13) Selection.HomeKey Unit:=wdStory ' TEI-Anfangscode (Header etc.) einfuegen: StatusBar = "Erzeuge TEI-Header..." With Selection .InsertAfter ("<?xml version=""1.0"" encoding=""ISO-8859-1"" standalone=""no"" ?>" & Chr(13)) .InsertAfter ("<?xml-stylesheet href=""../../dtd/hgkdiary-html.xsl"" type=""text/xsl""?>" & Chr(13)) .InsertAfter ("<!DOCTYPE TEI.2 SYSTEM ""../../dtd/hgkdiary.dtd"" [" & Chr(13)) .InsertAfter (" <!ENTITY img0000 SYSTEM ""../../images/preview/img0000.jpg"" NDATA jpeg>" & Chr(13)) .InsertAfter ("]>" & Chr(13)) .InsertAfter ("<TEI.2 xml:space=""preserve"">" & Chr(13)) .InsertAfter (" <teiHeader type=""text"">" & Chr(13)) .InsertAfter (" <fileDesc>" & Chr(13)) .InsertAfter (" <titleStmt>" & Chr(13)) .InsertAfter (" <title> Tagebücher Harry Graf Kessler " & MonthStr & "/" & YearStr & "</title>" & Chr(13)) .InsertAfter (" </titleStmt>" & Chr(13)) .InsertAfter (" <publicationStmt><p>Interne Arbeitsdatei</p>" & Chr(13)) .InsertAfter (" </publicationStmt>" & Chr(13)) .InsertAfter (" <sourceDesc><p>Grundlage: Tagebuchband ...</p>" & Chr(13)) .InsertAfter (" </sourceDesc>" & Chr(13)) .InsertAfter (" </fileDesc>" & Chr(13)) .InsertAfter (RevDesc & Chr(13)) .InsertAfter (" </teiHeader>" & Chr(13)) .InsertAfter (Chr(13)) .InsertAfter (" <text>" & Chr(13)) .InsertAfter (" <body>" & Chr(13)) End With ' am Ende sicherheitshalber Standardabsatz einfuegen, ' sonst ggf. Endlosschleife in der Suche Selection.EndKey Unit:=wdStory Selection.TypeParagraph '--------------------------------------------------------------------- ' Absatzformat: Normiertes Datum '--------------------------------------------------------------------- TranscrStyle = "Normiertes Datum" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With ' finden und markieren Rc = Selection.Find.Execute Do While (Rc) With Selection If Len(Selection.Range.Text) <> (10 + 1) Then MsgBox "Merkwürdiges Normdatum: " & Selection.Range.Text, vbExclamation, "Warnung" BadDate = True YearStr = "0000" Year = 0 MonthStr = "00" Month = 0 DayStr = "00" Day = 0 Else BadDate = False End If If FirstDay = True Then ' Datum ermitteln: If Not BadDate Then YearStr = Left(Selection.Range.Text, 4) MonthStr = Mid(Selection.Range.Text, 6, 2) DayStr = Mid(Selection.Range.Text, 9, 2) Year = Val(YearStr) Month = Val(MonthStr) Day = Val(DayStr) End If If (Year < 1880 Or Year > 1937) Then MsgBox "Merkwürdiges Tagebuchjahr (lt. Normdatum): " & YearStr, vbExclamation, "Warnung" YearStr = "0000" Year = 0 End If If (Month < 1 Or Month > 12) Then MsgBox "Merkwürdiger Tagebuchmonat (lt. Normdatum): " & MonthStr, vbExclamation, "Warnung" MonthStr = "00" Month = 0 End If If (Day < 1 Or Day > 31) Then MsgBox "Merkwürdiger Tagebuchtag (lt. Normdatum): " & DayStr, vbExclamation, "Warnung" DayStr = "00" Day = 0 End If DateStr = Trim(Str(Day)) & "." & Trim(Str(Month)) & "." & Trim(Str(Year)) ' Tags einfuegen: .InsertBefore ("<div type=""entry"" id=""d-") .InsertBefore ("<head>" & MonthName(Month) & " " & YearStr & "</head>") .InsertBefore ("<div type=""month"" id=""m-" & YearStr & "-" & MonthStr & """>") FirstDay = False Else ' Datum ermitteln: If Not BadDate Then DayStr = Mid(Selection.Range.Text, 9, 2) Day = Val(DayStr) End If If (Day < 1 Or Day > 31) Then MsgBox "Merkwürdiger Tagebuchtag (lt. Normdatum): " & DayStr, vbExclamation, "Warnung" DayStr = "00" Day = 0 End If DateStr = Trim(Str(Day)) & "." & Trim(Str(Month)) & "." & Trim(Str(Year)) ' Tags einfuegen: .InsertBefore ("</p></div><div type=""entry"" id=""d-") End If ' Enter ausschliessen .MoveEnd Unit:=wdCharacter, Count:=-1 .InsertAfter ("""><head>" & DateStr & " " & DayName(WeekDay(DateStr)) & "</head>") .Collapse Direction:=wdCollapseEnd ' finden und markieren Rc = .Find.Execute End With Loop End If '--------------------------------------------------------------------- ' Ort im Datum '--------------------------------------------------------------------- TranscrStyle = "Ort im Datum" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) ' <rs> nicht erlaubt InsertTags "<rs type=""loc.wrt"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Absatzformat: Datum '--------------------------------------------------------------------- ' Umwandlung muss nach "Ort im Datum" erfolgen, sonst Muell! TranscrStyle = "Datum" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Rc = Selection.Find.Execute Do While (Rc) With Selection .InsertBefore ("<opener><dateline>") ' Enter ausschliessen .MoveEnd Unit:=wdCharacter, Count:=-1 .InsertAfter ("</dateline></opener><p>") .Collapse Direction:=wdCollapseEnd ' finden und markieren Rc = .Find.Execute End With Loop End If '--------------------------------------------------------------------- ' Abbildungen (echte Graphiken) '--------------------------------------------------------------------- ' funktioniert nicht zuverlaessig - warum? If ActiveDocument.Shapes.Count > 0 Then MsgBox ("Achtung, Datei enthält Graphikobjekte! Diese werden z.Zt. nicht konvertiert.") End If ' GoTo Quit '--------------------------------------------------------------------- ' Abbildungen (Platzhalter-Sonderzeichen) '--------------------------------------------------------------------- StatusBar = "Konvertiere Platzhalter für Abbildungen..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(61561) .Replacement.Text = "<figure entity=""img0000"" rend=""center"" n=""dummy"">&img0000;</figure>" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll '--------------------------------------------------------------------- ' Absatzformat: Kommentar (nicht Stellen-K.!) '--------------------------------------------------------------------- TranscrStyle = "Kommentar" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Rc = Selection.Find.Execute Do While (Rc) With Selection .InsertBefore ("</p><p><note type=""rem"">") ' Enter ausschliessen .MoveEnd Unit:=wdCharacter, Count:=-1 .InsertAfter ("</note>") .Collapse Direction:=wdCollapseEnd Rc = .Find.Execute End With Loop End If '--------------------------------------------------------------------- ' Einfache Unterstreichung '--------------------------------------------------------------------- StatusBar = "Konvertiere Einfache Unterstreichungen..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Font.Underline = wdUnderlineSingle Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<hi rend=""ul.1"">", "</hi>" Loop '--------------------------------------------------------------------- ' Doppelte Unterstreichung '--------------------------------------------------------------------- StatusBar = "Konvertiere Doppelte Unterstreichung..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineDouble .StrikeThrough = False .DoubleStrikeThrough = False End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<hi rend=""ul.2"">", "</hi>" Loop '--------------------------------------------------------------------- ' Streichungen (durchgestrichen) '--------------------------------------------------------------------- StatusBar = "Konvertiere Streichungen (durchgestrichen)..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .StrikeThrough = True .DoubleStrikeThrough = False End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<del hand=""hgk"" rend=""st.1"">", "</del>" Loop '--------------------------------------------------------------------- ' Hochgestellte Zeichen '--------------------------------------------------------------------- StatusBar = "Konvertiere Hochgestellte Zeichen..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .Superscript = True .Subscript = False End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<hi rend=""sup"">", "</hi>" Loop '--------------------------------------------------------------------- ' Druckformat "Grossbuchstaben" '--------------------------------------------------------------------- StatusBar = "Konvertiere Druckformat 'Grossbuchstaben'..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .SmallCaps = False .AllCaps = True End With With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) Selection.Text = UCase(Selection.Text) Loop '--------------------------------------------------------------------- ' doppelte Anfuehrungszeichen links und rechts; Apostroph '--------------------------------------------------------------------- StatusBar = "Konvertiere Anführungszeichen etc. ..." ' vorlaeufig veroedet: GoTo Apo: Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = ChrW(8222) .Replacement.Text = "<q>" .Forward = True .Wrap = wdFindContinue .Format = True .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 = ChrW(8220) .Replacement.Text = "</q>" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Apo: 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 '--------------------------------------------------------------------- ' Person '--------------------------------------------------------------------- TranscrStyle = "Personen" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With ' finden und markieren Do While (Selection.Find.Execute) InsertTags "<rs type=""per"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Koerperschaft '--------------------------------------------------------------------- TranscrStyle = "Körperschaften" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""cor"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' ortsgebundene Koerperschaft '--------------------------------------------------------------------- TranscrStyle = "ortsgeb. Körperschaften" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""cor.loc"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Ort '--------------------------------------------------------------------- TranscrStyle = "Orte" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""loc"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Platz (nicht verwendet) '--------------------------------------------------------------------- TranscrStyle = "Plätze" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""pla"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Werk '--------------------------------------------------------------------- TranscrStyle = "Werke" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""wrk"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Zeitschrift '--------------------------------------------------------------------- TranscrStyle = "Zeitschriften" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""mag"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Fraglicher Registereintrag '--------------------------------------------------------------------- TranscrStyle = "Fraglicher Registereintrag" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<rs type=""unclear"">", "</rs>" Loop End If '--------------------------------------------------------------------- ' Fragliche Lesart '--------------------------------------------------------------------- TranscrStyle = "Fragliche Lesart" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<unclear>", "</unclear>" Loop End If '--------------------------------------------------------------------- ' Abschrift '--------------------------------------------------------------------- TranscrStyle = "Abschrift" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<seg type=""copy"">", "</seg>" Loop End If '--------------------------------------------------------------------- ' Kessler Abschrift '--------------------------------------------------------------------- TranscrStyle = "KessAb" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<seg type=""hgk"">", "</seg>" Loop End If '--------------------------------------------------------------------- ' anderes Schreibgeraet '--------------------------------------------------------------------- TranscrStyle = "Anderes Schreibgerät" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<seg type=""penshift"">", "</seg>" Loop End If '--------------------------------------------------------------------- ' Nachtraeglicher Eintrag '--------------------------------------------------------------------- TranscrStyle = "Nachträglicher Eintrag" If CheckStyle(TranscrStyle) Then Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles(TranscrStyle) Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Do While (Selection.Find.Execute) InsertTags "<add hand=""hgk"">", "</add>" Loop End If '--------------------------------------------------------------------- ' Berichtigung (nicht beruecksichtigt, da uneindeutig) '--------------------------------------------------------------------- ' StatusBar = "Konvertiere Berichtigungen..." ' Selection.HomeKey Unit:=wdStory ' Selection.Find.ClearFormatting ' Selection.Find.Replacement.ClearFormatting ' With Selection.Find ' .Text = "\[(*)\]" ' .Replacement.Text = "<corr>\1</corr>" ' .Forward = True ' .Wrap = wdFindStop ' .Format = True ' .MatchCase = False ' .MatchWholeWord = False ' .MatchWildcards = True ' .MatchSoundsLike = False ' .MatchAllWordForms = False ' End With ' Selection.Find.Execute Replace:=wdReplaceAll '--------------------------------------------------------------------- ' Umbrueche etc. einfuegen '--------------------------------------------------------------------- StatusBar = "Erzeuge Dateiabschluss..." Selection.WholeStory Selection.InsertAfter ("</p></div></div></body></text></TEI.2>") StatusBar = "XML-Tags schoener umbrechen ..." Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "(\<p\>)" .Replacement.Text = "^a\1" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll .Text = "(\</p\>)" .Execute Replace:=wdReplaceAll .Text = "(\<div?)" .Execute Replace:=wdReplaceAll .Text = "(\</div?\>)" .Execute Replace:=wdReplaceAll .Text = "(\<anchor\>)" .Execute Replace:=wdReplaceAll End With '--------------------------------------------------------------------- ' Tags einfaerben '--------------------------------------------------------------------- StatusBar = "XML-Tags einfaerben ..." Selection.WholeStory Selection.Style = ActiveDocument.Styles("Standard") Selection.Style = ActiveDocument.Styles("Standardschrift") Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.ColorIndex = wdBlue With Selection.Find .Text = "(\<[!\>]@\>)" .Replacement.Text = "\1" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False .Execute Replace:=wdReplaceAll End With '--------------------------------------------------------------------- ' Suchmaske aufraeumen: '--------------------------------------------------------------------- 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 Quit: Application.ScreenUpdating = True StatusBar = ThisMacro & ": fertig." End Sub Sub InsertTags(Before As String, After As String) ' nach erfolgreicher Suche Tags einfuegen, die keine Formatierung von ' ihrer Umgebung erben dürfen (sonst Probleme mit Verschachtelung) ' ' Nur fuer Text-, nicht fuer Absatzformate! With Selection .Collapse Direction:=wdCollapseStart .InsertBefore (Before) .Style = ActiveDocument.Styles("Standardschrift") .Collapse Direction:=wdCollapseEnd .Find.Execute .Collapse Direction:=wdCollapseEnd .InsertAfter (After) .Style = ActiveDocument.Styles("Standardschrift") .Collapse Direction:=wdCollapseEnd End With End Sub Function CheckStyle(MyStyle As String) ' Pruefen, ob Style existiert (ja: True) On Error Resume Next Dim Found As Boolean Dim MyType As Long MyType = 0 ' Error, falls nicht in Auflistung: MyType = ActiveDocument.Styles(MyStyle).Type If MyType = 0 Then CheckStyle = False MsgBox "Formatvorlage """ & MyStyle & """ nicht gefunden", vbExclamation, "Warnung" Else CheckStyle = True StatusBar = "Konvertiere " & MyStyle & "..." End If End Function