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