VBScript alle Word dateien einem Verzeichnis und Unterverzeichnissen öffnen und Makro Ausführen

Hallo,

ich versuche ein VBSScript zu basteln, welche mir weiter helfen kann.
Im einem Verzeichnis und Unterverzeichnissen sind mehrere Word und Excel Dateien mit gleiche Makro Name.
Ich möchte per vbsscript diese makro im hintergrund ausführen.
Wenn möglich, nur an die Dateien, die in letze Monat geändert worden sind.

An einem datei funktioniert per folgende code:

Sub wdStart()
Dim wdApp
Set wdApp = CreateObject("Word.Application")
'wdApp.Documents.Add
wdApp.visible = False
wdApp.Documents.Open "D:\test\1\2\3\test.doc"
wdApp.Run "Modul1.makro"
End Sub

wdStart

Kann mir jemand da weiter helfen.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 234292

Url: https://administrator.de/forum/vbscript-alle-word-dateien-einem-verzeichnis-und-unterverzeichnissen-oeffnen-und-makro-ausfuehren-234292.html

Ausgedruckt am: 10.04.2025 um 21:04 Uhr

5 Kommentare

Neuester Kommentar

Hallo alex, Willkommen im Forum.
Das gewünschte Kannst du hiermit machen (Kommentare im Code). Die Funktion welche jeweils aufgerufen werden soll legst du in Zeile 57 und 76 fest jeweils für Excel- und Word-Dokumente

'Pfad zu den Dokumenten  
Const strPathDocs = "E:\dokumente"  
'Logfile für eventuell auftretende Fehler  
Const strPathLogfile = "E:\dokumente\logfile.txt"  
'Erweiterungen der Dateien die bearbeitet werden sollen  
arrFileExtensions = Array("doc","docm","xlsm","xls")  

Set fso = Wscript.CreateObject("Scripting.Filesystemobject")  
Set objShell = CreateObject("Wscript.Shell")  
Dim intDocCount, intErrCount, objExcel, objWord
Set objExcel = CreateObject("Excel.Application")  
Set objWord = WScript.CreateObject("Word.Application")  
'Applikation anzeigen und eventuelle Dialoge für Batchbetrieb unterdrücken  
objExcel.Visible = True
objExcel.DisplayAlerts = 0
objWord.Visible = True
objWord.DisplayAlerts = 0

'Im Ordner Rekursiv alle Dokumente mit den angegebenen Extensions verarbeiten  
parseFolders fso.GetFolder(strPathDocs), True

objExcel.DisplayAlerts = True
objExcel.Quit
objWord.DisplayAlerts = True
objWord.Quit

If intErrCount = 0 Then
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet.", vbInformation, "Verarbeitung abgeschlossen"  
Else
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet." & vbCrLf & "Davon ist bei " & intErrCount & " Dokumenten ein Fehler aufgetreten!", vbInformation, "Verarbeitung abgeschlossen"  
	objShell.Run "Notepad.exe " & strPathLogfile  
End If

Set objShell = Nothing
Set objWord = Nothing
Set objExcel = Nothing
Set fso = Nothing
'Ende  

Function parseFolders(fldr, boolRecursion)
    For Each file In fldr.Files
    	For i = 0 To UBound(arrFileExtensions)
			If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) And file.DateLastModified > DateAdd("m",-1,Now()) Then  
				intDocCount = intDocCount + 1 
				Select Case Left(LCase(fso.GetExtensionName(file.Path)),2)
					Case "xl"	' wenn es ein Excel-Workbook ist ....  
						
						'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
						On Error Resume Next
			            Set objWB = objExcel.Workbooks.Open(file.Path)
			            If Err.Number <> 0 Then
			            	intErrCount = intErrCount + 1
			            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
                                        Err.Clear
			            Else
			            	' Funktion im Workbook ausführen  
			            	objExcel.Run "Modul1.MyTestModul"  
			            	'-------------------------------  
			            	objWB.Save
			            	objWB.Close
			            	WriteLog "Workbook wurde verarbeitet: ->'" & file.Path & "'"  
			            End If
						
						
					Case "do"	' wenn es ein Word-Dokument ist ....  
						
						'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
			            On Error Resume Next
			            Set objDoc = objWord.Documents.Open(file.Path)
			            If Err.Number <> 0 Then
			            	intErrCount = intErrCount + 1
			            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
                                        Err.Clear
			            Else
			            	'Funktion ausführen  
			            	objWord.Run "Modul1.MyTestModul"  
			            	'------------------  
			            	objDoc.Save
			            	objDoc.Close
			            	WriteLog "Dokument wurde verarbeitet: ->'" & file.Path & "'"  
			            End If
			            
				End Select
				Exit For
	         End If
		Next
    Next
    
    'Funktion wird rekursiv aufrufen wenn das durchsuchen aller Unterordner gewünscht ist  
    If boolRecursion Then
		For Each subFolder in fldr.SubFolders
			parseFolders subFolder, True
		Next
	End If
End Function

Function WriteLog(strText)
	Set objLog = fso.OpenTextFile(strPathLogfile,8,True)
	logline = Now & " - " & strText  
	objLog.WriteLine(logline)
	objLog.Close
End Function

Grüße Uwe

Hallo Uwe,

viele Dank, funktioniert soweit ok bis auf Fehlermeldung zum Schluss.

http://s1.directupload.net/images/140402/3d59u86k.png

Wie kann ich noch ergänzen, dass nur im letzten Monat geänderte Dateien geöffnet werden?

Danke nochmal!

Gruß Alex

Zitat von @alex-fw:
viele Dank, funktioniert soweit ok bis auf Fehlermeldung zum Schluss.
http://s1.directupload.net/images/140402/3d59u86k.png

alter geile Fehlermeldung, die kenn ich noch nicht, kann ich hier aber auch nicht nachvollziehen

Wie kann ich noch ergänzen, dass nur im letzten Monat geänderte Dateien geöffnet werden?

ist oben ergänzt ...

Hallo Uwe,

ich habe den Code getrennt, in Excel und Word
Excel funktioniert gut, Word macht problemme.
Wo die Fehler her kommt habe ich gefunden,
Zeile 22
wenn ich die
objWord.DisplayAlerts = True
objWord.Quit
ausblende, wird Makro an erste Dokument in Verzeichnissen ausgeführt, alle andere werden nicht angesprochen.
es wird immer bei die erste Datei in Verzeichnissen die gewünschte Funktionen ausgeführt,
bei die weiteren kommt Fehler:
03.04.2014 09:45:13 - Dokument wurde verarbeitet: ->'G:\1.doc
03.04.2014 09:45:13 - !!ERROR!! Fehler beim Ã¶ffnen der Datei: -> 'G:\2.doc

''Word  
'Pfad zu den Dokumenten  
Const strPathDocs = "D:\test"  
'Logfile für eventuell auftretende Fehler  
Const strPathLogfile = "G:\logfile.txt"  
'Erweiterungen der Dateien die bearbeitet werden sollen  
arrFileExtensions = Array("docm","doc")  

Set fso = Wscript.CreateObject("Scripting.Filesystemobject")  
Set objShell = CreateObject("Wscript.Shell")  
Dim intDocCount, intErrCount, objWord
Set objWord = WScript.CreateObject("Word.Application")  

'Applikation anzeigen und eventuelle Dialoge für Batchbetrieb unterdrücken  
objWord.Visible = False
objWord.DisplayAlerts = 0


'Im Ordner Rekursiv alle Dokumente mit den angegebenen Extensions verarbeiten  
parseFolders fso.GetFolder(strPathDocs), True


objWord.DisplayAlerts = True
objWord.Quit




Set objShell = Nothing

Set objExcel = Nothing
Set fso = Nothing
'Ende  

If intErrCount = 0 Then
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet.", vbInformation, "Verarbeitung abgeschlossen"  
Else
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet." & vbCrLf & "Davon ist bei " & intErrCount & " Dokumenten ein Fehler aufgetreten!", vbInformation, "Verarbeitung abgeschlossen"  
	objShell.Run "Notepad.exe " & strPathLogfile  
End If

Function parseFolders(fldr, boolRecursion)
    For Each file In fldr.Files
    	For i = 0 To UBound(arrFileExtensions)
			If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) And file.DateLastModified > DateAdd("m",-1,Now()) Then  
				intDocCount = intDocCount + 1 
				Select Case Left(LCase(fso.GetExtensionName(file.Path)),2)
					Case "do"	' wenn es ein Word-Dokument ist ....  
						
						'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
			            On Error Resume Next
			            Set objDoc = objWord.Documents.Open(file.Path)
			            If Err.Number <> 0 Then
			            	intErrCount = intErrCount + 1
			            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
			            Else
			            	'Funktion ausführen  
			            	objWord.Run "backup.pdf"  
			            	'------------------  
			            	'objDoc.Save  
			            	objDoc.Close
			            	WriteLog "Dokument wurde verarbeitet: ->'" & file.Path & "'"  
			            End If
			            
				End Select
				Exit For
	         End If
		Next
    Next
    
    'Funktion wird rekursiv aufrufen wenn das durchsuchen aller Unterordner gewünscht ist  
    If boolRecursion Then
		For Each subFolder in fldr.SubFolders
			parseFolders subFolder, True
		Next
	End If
End Function

Function WriteLog(strText)
	Set objLog = fso.OpenTextFile(strPathLogfile,8,True)
	logline = Now & " - " & strText  
	objLog.WriteLine(logline)
	objLog.Close
End Function

'Excel  
'Pfad zu den Dokumenten  
Const strPathDocs = "D:\test"  
'Logfile für eventuell auftretende Fehler  
Const strPathLogfile = "G:\logfile.txt"  
'Erweiterungen der Dateien die bearbeitet werden sollen  
arrFileExtensions = Array("xlsm","xls")  

Set fso = Wscript.CreateObject("Scripting.Filesystemobject")  
Set objShell = CreateObject("Wscript.Shell")  
Dim intDocCount, intErrCount, objExcel
Set objExcel = CreateObject("Excel.Application")  

'Applikation anzeigen und eventuelle Dialoge für Batchbetrieb unterdrücken  
objExcel.Visible = False
objExcel.DisplayAlerts = 0


'Im Ordner Rekursiv alle Dokumente mit den angegebenen Extensions verarbeiten  
parseFolders fso.GetFolder(strPathDocs), True


objExcel.DisplayAlerts = True
objExcel.Quit




Set objShell = Nothing

Set objExcel = Nothing
Set fso = Nothing
'Ende  

If intErrCount = 0 Then
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet.", vbInformation, "Verarbeitung abgeschlossen"  
Else
	MsgBox "Es wurden insgesamt " & intDocCount & " Dokumente verarbeitet." & vbCrLf & "Davon ist bei " & intErrCount & " Dokumenten ein Fehler aufgetreten!", vbInformation, "Verarbeitung abgeschlossen"  
	objShell.Run "Notepad.exe " & strPathLogfile  
End If

Function parseFolders(fldr, boolRecursion)
    For Each file In fldr.Files
    	For i = 0 To UBound(arrFileExtensions)
			If LCase(arrFileExtensions(i)) = LCase(fso.GetExtensionName(file.Path)) And file.DateLastModified > DateAdd("m",-1,Now()) Then  
				intDocCount = intDocCount + 1 
				Select Case Left(LCase(fso.GetExtensionName(file.Path)),2)
					Case "xl"	' wenn es ein Excel-Workbook ist ....  
						
						'Fehlerbehandlung für den Fall das ein Fehler beim Öffnen eines Dokumentes auftritt  
						On Error Resume Next
			            Set objWB = objExcel.Workbooks.Open(file.Path)
			            If Err.Number <> 0 Then
			            	intErrCount = intErrCount + 1
			            	WriteLog "!!ERROR!! Fehler beim öffnen der Datei: -> '" & file.Path & "'"  
			            Else
			            	' Funktion im Workbook ausführen  
			            	objExcel.Run "backup.pdf"  
			            	'-------------------------------  
			            	'objWB.Save  
			            	objWB.Close
			            	WriteLog "Workbook wurde verarbeitet: ->'" & file.Path & "'"  
			            End If
						
						
		
			
			            
				End Select
				Exit For
	         End If
		Next
    Next
    
    'Funktion wird rekursiv aufrufen wenn das durchsuchen aller Unterordner gewünscht ist  
    If boolRecursion Then
		For Each subFolder in fldr.SubFolders
			parseFolders subFolder, True
		Next
	End If
End Function

Function WriteLog(strText)
	Set objLog = fso.OpenTextFile(strPathLogfile,8,True)
	logline = Now & " - " & strText  
	objLog.WriteLine(logline)
	objLog.Close
End Function