Word - Kontrollkästchen (Formularsteuerelement) auslesen...

OptionExplicit
ConstwdFieldFormCheckBox=71
DimblnTMPAsBoolean
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 04.04.2018
' Purpose   : Aus Worddokumenten Kontrollkästchen (Formularsteuerelement)
'--------------------------------------------------------------------------
PublicSubMain()
' Dimensionieren der Variablen
DimwksSheetAsWorksheet
DimobjDocumentAsObject
DimfmControlAsObject
DimlngLastRowAsLong
DimstrDateiAsString
DimstrPathAsString
DimobjAppAsObject
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt
WithApplication
.ScreenUpdating=False
.EnableEvents=False
lngCalc=.Calculation
.Calculation=xlCalculationManual
.DisplayAlerts=False
EndWith
' Pfad anpassen - fester Pfad vorgeben
'strPath = "C:\Temp\Word\"
' Pfad anpassen - Worddateien sind im gleichen
' Verzeichnis wie DIESE Exceldatei
strPath=ThisWorkbook.Path&Application.PathSeparator
SetobjApp=OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
IfNotobjAppIsNothingThen
' Temporäres Tabellenblatt hinzufügen
Worksheets.AddAfter:=Worksheets(Worksheets.Count)
SetwksSheet=ActiveSheet
strDatei=Dir$(strPath&"*.doc*",vbDirectory)
DoWhilestrDatei<>""
' Worddokument öffnen
SetobjDocument=objApp.Documents.Open_
(strPath&strDatei)
' WENN vorhanden werden die Kontrollkästchen ausgelesen
IfobjDocument.FormFields.Count<>0Then
' Nimm jedes Objekt, das zu den FormFields gehört
ForEachfmControlInobjDocument.FormFields
' Bestimme jetzt die Anzahl der Zeilen in Spalte A
WithwksSheet
lngLastRow=IIf(IsEmpty(.Cells(.Rows.Count,1)),_
.Cells(.Rows.Count,1)._
End(xlUp).Row,.Rows.Count)+1
EndWith
' Dateiname in die erste Zelle schreiben
wksSheet.Cells(lngLastRow,1).Value=strDatei
' Pfad in den Kommentar schreiben
wksSheet.Cells(lngLastRow,1).AddComment.Text_
strPath&strDatei
WithfmControl
' Ist es ein Kontrollkästchen?
If.Type=wdFieldFormCheckBoxThen
' Ist der Haken gesetzt?
If.CheckBox.Value=TrueThen
wksSheet.Cells(lngLastRow,2).Value=_
"Typ: "&.Type
wksSheet.Cells(lngLastRow,3).Value=_
"Haken gesetzt!"
' Sonst
Else
wksSheet.Cells(lngLastRow,2).Value=_
"Typ: "&.Type
wksSheet.Cells(lngLastRow,3).Value=_
"Haken nicht gesetzt!"
EndIf
Else
wksSheet.Cells(lngLastRow,4).Value=_
"Typ: "&.Type
wksSheet.Cells(lngLastRow,5).Value=_
.Range.Text
EndIf
EndWith
NextfmControl
EndIf
' Worddokument ohne speichern schlissen
objDocument.CloseFalse
' Die nächste Datei nehmen
strDatei=Dir$()
SetobjDocument=Nothing
Loop
' Spaltenbreite automatisch setzen
wksSheet.Cells.EntireColumn.AutoFit
Else
MsgBox"Applikation nicht installiert!"
EndIf
Fin:
IfNotobjAppIsNothingThen
IfblnTMP=TrueThen
objApp.Quit
blnTMP=False
EndIf
EndIf
' Objektvariablen leeren
SetwksSheet=Nothing
SetobjDocument=Nothing
SetobjApp=Nothing
' Die Applikation aufwecken
WithApplication
.ScreenUpdating=True
.AskToUpdateLinks=True
.EnableEvents=True
.Calculation=lngCalc
.DisplayAlerts=True
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 04.04.2018
' Purpose   : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
DimobjAppAsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
blnTMP=True
IfblnVisible=TrueThen
OnErrorResumeNext
objApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction