Option Explicit
Const wdContentControlCheckBox = 8
Dim blnTMP As Boolean
Public Sub Main()
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim conControl As Object
Dim lngLastRow As Long
Dim strDatei As String
Dim strPath As String
Dim objApp As Object
Dim lngCalc As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
strPath = ThisWorkbook.Path & Application.PathSeparator
Set objApp = OffApp("Word")
If Not objApp Is Nothing Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set wksSheet = ActiveSheet
strDatei = Dir$(strPath & "*.doc*", vbDirectory)
Do While strDatei <> ""
Set objDocument = objApp.Documents.Open _
(strPath & strDatei)
If objDocument.ContentControls.Count <> 0 Then
For Each conControl In objDocument.ContentControls
With wksSheet
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
.Cells(.Rows.Count, 1). _
End(xlUp).Row, .Rows.Count) + 1
End With
wksSheet.Cells(lngLastRow, 1).Value = strDatei
wksSheet.Cells(lngLastRow, 1).AddComment.Text _
strPath & strDatei
With conControl
If .Type = wdContentControlCheckBox Then
wksSheet.Cells(lngLastRow, 2).Value = _
"Typ: " & .Type
wksSheet.Cells(lngLastRow, 3).Value = _
"Tag: " & .Tag
wksSheet.Cells(lngLastRow, 4).Value = _
"Text: " & .Range.Text
wksSheet.Cells(lngLastRow, 5).Value = _
"Haken: " & .Checked
Else
wksSheet.Cells(lngLastRow, 6).Value = _
"Typ: " & .Type
wksSheet.Cells(lngLastRow, 7).Value = _
"Tag: " & .Tag
wksSheet.Cells(lngLastRow, 8).Value = _
"Text: " & .Range.Text
End If
End With
Next conControl
End If
objDocument.Close False
strDatei = Dir$()
Set objDocument = Nothing
Loop
wksSheet.Cells.EntireColumn.AutoFit
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set wksSheet = Nothing
Set objDocument = Nothing
Set objApp = Nothing
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.CutCopyMode = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function