alex-fw
Apr 02, 2014
view7000
view5
0
Goto Top

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

GermanQuestionVB for ApplicationsDevelopment
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.
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 234292

Url: https://administrator.de/contentid/234292

Printed on: April 18, 2024 at 03:04 o'clock

5 Comments
Latest comment
Goto Top
Member: colinardo
colinardo Apr 02, 2014, updated at Apr 04, 2014 at 10:41:38 (UTC)
Goto Top
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
heart1
Member: alex-fw
alex-fw Apr 02, 2014 at 12:31:34 (UTC)
Goto Top
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
Member: colinardo
colinardo Apr 02, 2014 updated at 12:44:02 (UTC)
Goto Top
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 face-smile

Wie kann ich noch ergänzen, dass nur im letzten Monat geänderte Dateien geöffnet werden?
ist oben ergänzt ...
Member: alex-fw
alex-fw Apr 02, 2014, updated at Apr 04, 2014 at 05:08:54 (UTC)
Goto Top
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

kannst du bitte mir weiterhelfen
Member: alex-fw
alex-fw Apr 04, 2014 at 09:34:20 (UTC)
Goto Top
Hallo,

kann mir keine weiterhelfen?
GermanQuestionVB for ApplicationsDevelopment
Hotly discussed
AlexWishaHow to set up and configure a Linux GRE tunnelAlexWisha - 3 CommentsDaniEnd of Support dates for Office 2016, 2019 Apps und Productivity ServersDani - 1 Comment