Aha burda amk
Attribute VB_Name = "KapitelExtraktion"
Option Explicit
Sub ExtrahiereKapitelAusWordDokumenten()
Dim strKfg As String, strOrd As String
strKfg = InputBox("Pfad zur Konfigurations-Word-Datei (Kapitelliste):", "Konfigurationsdatei")
If strKfg = "" Or Dir(strKfg) = "" Then MsgBox "Datei nicht gefunden.", vbCritical: Exit Sub
strOrd = InputBox("Pfad zum Quellordner mit den Word-Dokumenten:", "Quellordner")
If strOrd = "" Then Exit Sub
If Right(strOrd, 1) <> "\" Then strOrd = strOrd & "\"
If Dir(Left(strOrd, Len(strOrd) - 1), vbDirectory) = "" Then MsgBox "Ordner nicht gefunden.", vbCritical: Exit Sub
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Cells.Clear
With ws.Range("A1:C1")
.Value = Array("Quelldokument", "Kapitel", "Kapiteltext")
.Font.Bold = True: .Font.Color = RGB(255, 255, 255): .Interior.Color = RGB(31, 78, 121)
End With
Dim wdApp As Object
On Error Resume Next: Set wdApp = GetObject(, "Word.Application"): On Error GoTo 0
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Dim arrKap() As String, nKap As Integer
arrKap = LeseKapitel(wdApp, strKfg, nKap)
If nKap = 0 Then MsgBox "Keine Kapitel in Konfigurationsdatei gefunden.", vbExclamation: Exit Sub
Dim lngZ As Long: lngZ = 2
Dim strD As String: strD = Dir(strOrd & "*.docx")
Application.ScreenUpdating = False
Do While strD <> ""
If LCase(strOrd & strD) <> LCase(strKfg) Then
Dim wdDok As Object
On Error Resume Next
Set wdDok = wdApp.Documents.Open(strOrd & strD, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
On Error GoTo 0
If Not wdDok Is Nothing Then
SuchUndSchreibe wdDok, arrKap, nKap, ws, lngZ, strD
wdDok.Close False: Set wdDok = Nothing
End If
End If
strD = Dir()
Loop
ws.Columns("A").ColumnWidth = 28: ws.Columns("B").ColumnWidth = 33
ws.Columns("C").ColumnWidth = 85: ws.Columns("C").WrapText = True
ws.Range("A1:C1").AutoFilter
Application.ScreenUpdating = True
MsgBox "Fertig! " & (lngZ - 2) & " Kapiteleintraege extrahiert.", vbInformation
End Sub
Private Function LeseKapitel(wdApp As Object, strPfad As String, ByRef n As Integer) As String()
Dim wdDok As Object, oPara As Object, arr() As String, s As String
n = 0: ReDim arr(0)
Set wdDok = wdApp.Documents.Open(strPfad, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
For Each oPara In wdDok.Paragraphs
s = Trim(Left(oPara.Range.Text, Len(oPara.Range.Text) - 1))
If Len(s) > 0 Then ReDim Preserve arr(n): arr(n) = s: n = n + 1
Next oPara
wdDok.Close False: LeseKapitel = arr
End Function
Private Sub SuchUndSchreibe(wdDok As Object, arr() As String, n As Integer, _
ws As Worksheet, ByRef lngZ As Long, strDatei As String)
Dim oPara As Object, sTxt As String, sKap As String, sBody As String, bSammle As Boolean
For Each oPara In wdDok.Paragraphs
sTxt = Trim(Left(oPara.Range.Text, Len(oPara.Range.Text) - 1))
If LCase(oPara.Style.NameLocal) Like "heading*" Or LCase(oPara.Style.NameLocal) Like "überschrift*" Then
If bSammle And Len(Trim(sBody)) > 0 Then
SchreibeZeile ws, lngZ, strDatei, sKap, Trim(sBody): lngZ = lngZ + 1
End If
bSammle = False: sKap = "": sBody = ""
If KapitelTreffer(sTxt, arr, n) Then bSammle = True: sKap = sTxt
ElseIf bSammle And Len(sTxt) > 0 Then
sBody = sBody & IIf(Len(sBody) > 0, Chr(10), "") & sTxt
End If
Next oPara
If bSammle And Len(Trim(sBody)) > 0 Then SchreibeZeile ws, lngZ, strDatei, sKap, Trim(sBody): lngZ = lngZ + 1
End Sub
Private Function KapitelTreffer(sUeber As String, arr() As String, n As Integer) As Boolean
Dim i As Integer, sU As String, sS As String
sU = LCase(OhneNummer(sUeber))
For i = 0 To n - 1
sS = LCase(OhneNummer(arr(i)))
If sU = sS Or LCase(sUeber) = LCase(arr(i)) Then KapitelTreffer = True: Exit Function
If Len(sS) >= 4 And InStr(1, sU, sS, vbTextCompare) > 0 Then KapitelTreffer = True: Exit Function
Next i
End Function
Private Function OhneNummer(s As String) As String
Dim r As String: r = Trim(s)
Dim i As Integer: i = 1
Do While i <= Len(r)
Select Case Mid(r, i, 1)
Case "0" To "9": i = i + 1
Case ".", " ": If i > 1 Then r = Trim(Mid(r, i + 1)): i = 1 Else Exit Do
Case Else: Exit Do
End Select
Loop
OhneNummer = r
End Function
Private Sub SchreibeZeile(ws As Worksheet, z As Long, sD As String, sK As String, sT As String)
ws.Cells(z, 1).Value = sD: ws.Cells(z, 2).Value = sK
ws.Cells(z, 3).Value = IIf(Len(sT) > 32000, Left(sT, 32000) & " [gekuerzt]", sT)
If z Mod 2 = 0 Then ws.Range(ws.Cells(z, 1), ws.Cells(z, 3)).Interior.Color = RGB(235, 241, 250)
End Sub