Option Explicit
Dim kapitel()
Private WithEvents beenden As MSForms.CommandButton
Private WithEvents löschen As MSForms.CommandButton
Dim doc
Private Sub UserForm_Initialize()
Dim dlg As Dialog
Dim kap
Dim i As Long
Dim name As String
Dim neubox
Dim neubutton
name = ActiveDocument.name
Set dlg = Dialogs(wdDialogFileOpen)
With dlg
If .Display = 0 Then
MsgBox "Die Auswahl wurde abgebrochen, das Programm wird beendet!", , "Abbruch Dateiauswahl"
End
Else
Set doc = Documents.Open(FileName:=dlg.name)
End If
End With
ReDim kapitel(3, 0)
kapitel(0, 0) = 0
For Each kap In doc.Paragraphs
If kap.OutlineLevel < 10 And kap.Range.Text <> Chr(13) Then
kapitel(0, 0) = kapitel(0, 0) + 1
ReDim Preserve kapitel(3, kapitel(0, 0))
kapitel(0, kapitel(0, 0)) = Replace(kap.Range.Text, Chr(12), "")
kapitel(1, kapitel(0, 0)) = kap.Range.Start
End If
Next kap
Me.Caption = "Auswahl der Kapitel"
Me.Height = kapitel(0, 0) * 25 + 100
Me.Width = 500
Me.ScrollBars = fmScrollBarsVertical
Me.ScrollHeight = kapitel(0, 0) * 25 + 300
Set neubox = Me.Controls.Add("forms.Label.1")
neubox.Height = 40
neubox.Width = 400
neubox.Top = 10
neubox.Left = 20
neubox.Caption = "Bitte wählen Sie die Dateien aus, die erhalten bleiben sollen!"
Set neubox = Nothing
For i = 1 To kapitel(0, 0)
Set neubox = Me.Controls.Add("forms.CheckBox.1")
neubox.Height = 40
neubox.Top = i * 25
neubox.Left = 20
neubox.Caption = kapitel(0, i)
neubox.Font.Size = 8
Set neubox = Nothing
Next i
For i = 1 To 2
Set neubutton = Controls.Add("Forms.CommandButton.1", , True)
With neubutton
Select Case i
Case 1
.Caption = "löschen"
.Left = 75
.Top = kapitel(0, 0) * 25 + 40
.Width = 100
.Height = 20
Set löschen = neubutton
Case 2
.Caption = "beenden"
.Left = 325
.Top = kapitel(0, 0) * 25 + 40
.Width = 100
.Height = 20
Set beenden = neubutton
End Select
End With
Next i
End Sub
Private Sub löschen_click()
Dim i As Long
Dim stelle As Range
For i = 1 To kapitel(0, 0)
If Me.Controls("CheckBox" & i).Value = True Then kapitel(3, i) = "x"
Next i
For i = kapitel(0, 0) To 1 Step -1
If kapitel(3, i) = "x" Then
If i = kapitel(0, 0) Then
doc.Range(kapitel(1, i), kapitel(1, i)).Select
Else
doc.Range(kapitel(1, i), kapitel(1, i + 1)).Select
End If
Set stelle = Selection.Bookmarks("\HeadingLevel").Range
While Left(stelle.Text, 1) = Chr(12)
stelle.SetRange stelle.Start + 1, stelle.End
Wend
While Right(stelle.Text, 1) = Chr(12)
stelle.SetRange stelle.Start, stelle.End - 1
Wend
stelle.Select
Selection.Delete
End If
Next i
Unload UserForm1
End Sub
Private Sub beenden_click()
Unload UserForm1
End Sub