Word - Inhaltssteuerelemente auslesen...

Frage: Es gibt einige Worddokumente mit Inhaltssteuerelementen. Diese möchte ich gerne nach Excel auslesen. Wie geht das?

Hier noch eine Beispieldatei: Word - Inhaltssteuerelemente auslesen...[ZIP 100 KB]

Im Download ist das Exceldokument sowie ein paar Worddokumente mit Beispieldaten.

Option Explicit
Const wdContentControlCheckBox = 8
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 12.12.2012 
' Purpose   : Aus Worddokumenten Inhaltssteuerelemente auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    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
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Pfad anpassen - fester Pfad vorgeben 
    'strPath = "C:\Temp\Word\" 
    ' Pfad anpassen - Worddateien sind im gleichen 
    'Verzeichnis wie diese Exceldatei 
    strPath = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        ' Temporäres Tabellenblatt hinzufügen 
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        Set wksSheet = ActiveSheet
        strDatei = Dir$(strPath & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            ' Worddokument öffnen 
            Set objDocument = objApp.Documents.Open _
                (strPath & strDatei)
            ' WENN vorhanden werden die Inhaltssteuerelemente ausgelesen 
            If objDocument.ContentControls.Count <> 0 Then
                For Each conControl In objDocument.ContentControls
                    ' Bestimme jetzt die Anzahl der Zeilen in Spalte A 
                    With wksSheet
                        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                            .Cells(.Rows.Count, 1). _
                            End(xlUp).Row, .Rows.Count) + 1
                    End With
                    ' Dateiname in die erste Zelle schreiben 
                    wksSheet.Cells(lngLastRow, 1).Value = strDatei
                    ' Pfad in den Kommentar schreiben 
                    wksSheet.Cells(lngLastRow + 1, 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
            ' Worddokument ohne speichern schliessen 
            objDocument.Close False
            ' Die nächste Datei nehmen 
            strDatei = Dir$()
            Set objDocument = Nothing
        Loop
        ' Spaltenbreite automatisch setzen 
        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
    ' Objektvariablen leeren 
    Set wksSheet = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    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

' Ausgegeben in WORD per Debug.Print 
' With conControl 
'     If .Type = wdContentControlCheckBox Then 
'         Debug.Print .Type & " - " & .Tag & _
'             " - " & .Range.Text & " - " & .Checked 
'     Else 
'         Debug.Print .Type & " - " & .Tag & " - " & .Range.Text 
'     End If 
' End With 

' Ergibt für das Dokument im Anhang: 
'0 - Titel - Titel 
'1 - Auftragsart - Worum geht es? 
'8 -  - ? - Wahr 
'8 -  - ? - Falsch 
'8 -  - ? - Wahr 
'8 -  - ? - Wahr 
'8 -  - ? - Falsch 
'8 -  - ? - Falsch 
'8 -  - ? - Falsch 
'1 - Leiter - Peter Muster 
'1 - Auftraggeber - Peter Muster 
'1 - Kunde - Kunde 1 
'6 - Beginn - 20.12.2012 
'6 - Ende - 21.12.2012 
'0 - Problembeschreibung - Keine Probleme bekannt 
'1 - Gesamtziel - Kein Ziel 
'0 - Teilziele - Teilziel 1 
'Teilziel 2 
'Teilziel 3 
'0 - Ergebnisse - Ergebnis 1 
'Ergebnis 2 
'0 - Leistungen - Leistung 1 
'Leistung 2 
'0 - Randbedingung - Randbedingung 
'0 - Auftragsorganisation - Firma 1 
'Peter Muster 
'Abteilung 1 
'Jobbezeichnung 1 
'Firma 2 
'Frank Muster 
'Abteilung 2 
'Jobbezeichnung 2 
'1 - Kosten - 2000 Euro 
'1 - Sonstiges - Keine weiteren Informationen 
'1 -  - Keine Anlagen 

' Die Konstanten: 
'wdContentControlBuildingBlockGallery = 5 
'wdContentControlCheckBox = 8 
'wdContentControlComboBox = 3 
'wdContentControlDate = 6 
'wdContentControlDropdownList = 4 
'wdContentControlGroup = 7 
'wdContentControlPicture = 2 
'wdContentControlRichText = 0 
'wdContentControlText = 1 

Verschiedene Links zu dem Thema:

Link 1
Link 2
Link 3
Link 4

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...