Hallo,
ich lese aus ca 300 Dateien die Dokumenteigenschaften aus, was leider pro Dokument ein paar Sekunden dauert, was sich addiert. Der Code ist folgender:
Code:
Dateiname = Dir("\\server\*.doc*")
Do While Dateiname <> ""
strDateiname = "\\server\" & Dateiname & ""
Set objDatei = GetObject(strDateiname)
Set dp = objDatei.ContentTypeProperties
ThisWorkbook.Worksheets("Dokumentenbibliothek").Range("b" & letzteZeile_excel_DB + 1).Offset(i, 0) = dp("User / Support")
i = i + 1
Dateiname = Dir$()
Loop
Ich konnte herausfinden, dass die Zeile "Set objDatei = GetObject(strDateiname)"
diejenige ist, die so lange braucht zum Ausführen.
Kann man das irgendwie eleganter lösen?
Vielen Dank und Gruß!
Hallo,
bleibt die Zeit zum Ausführen immer gleich oder dauert es von Datei zu Datei immer länger? Wenn das zweite der Fall ist, setze die Variablen auf Nothing.
PHP-Code:
Dateiname = Dir("\\server\*.doc*")
Do While Dateiname <> ""
strDateiname = "\\server\" & Dateiname & ""
Set objDatei = GetObject(strDateiname)
Set dp = objDatei.ContentTypeProperties
ThisWorkbook.Worksheets("Dokumentenbibliothek").Range("b" & letzteZeile_excel_DB + 1).Offset(i, 0) = dp("User / Support")
i = i + 1
Set dp = Nothing
Set objDatei = Nothing
Dateiname = Dir$()
Loop
Hallo Stefan,
danke erstmal für den Hinweis.
Leider dauert es immer gleichlang, auch beim ersten Durchlauf des Loops.
Gruß
Hallo,
mal ungetestet
Code:
Sub prcX()
Dim objWord As Object, objDatei As Object, dp As Object
Dim strDateiname As String
Dim i As Long
Set objWord = GetObject(, "Word.Application")
Dateiname = Dir("\\server\*.doc*")
Do While Dateiname <> ""
strDateiname = "\\server\" & Dateiname & ""
Set objDatei = objWord.documents.Open(strDateiname)
Set dp = objDatei.ContentTypeProperties
ThisWorkbook.Worksheets("Dokumentenbibliothek").Range("b" & letzteZeile_excel_DB + 1).Offset(i, 0) = dp("User / Support")
i = i + 1
objDatei.activedocument.Close False
objDatei.Quit
objDatei = Nothing
Dateiname = Dir$()
Loop
objWord = Nothing
End Sub
Damit bekomme ich leider in der Zeile
Code:
Set objWord = GetObject(, "Word.Application")
den Laufzeitfehler "Objekterstellung durch ActiveX Komponente nicht möglich"
Hallo,
beim ersten Lauf im Einzelschrittmodus gab es bei mir diesen Fehler auch. Danach nicht mehr
Ich habe keine Ahnung weshalb und konnte deshalb meine Codeänderung nicht testen (zumindest den Teil mit der Verbindung zu Word).
Code:
Sub prcX()
Dim objWord As Object, objDatei As Object, dp As Object
Dim strDateiname As String
Dim i As Long
On Error GoTo errHandling
Set objWord = GetObject(class:="Word.Application")
On Error GoTo 0
Dateiname = Dir("\\server\*.doc*")
Do While Dateiname <> ""
strDateiname = "\\server\" & Dateiname & ""
Set objDatei = objWord.Documents.Open(strDateiname)
Set dp = objDatei.ContentTypeProperties
ThisWorkbook.Worksheets("Dokumentenbibliothek").Range("b" & letzteZeile_excel_DB + 1).Offset(i, 0) = dp("User / Support")
i = i + 1
objDatei.activedocument.Close False
objDatei.Quit
objDatei = Nothing
Dateiname = Dir$()
Loop
objWord = Nothing
Exit Sub
errHandling:
Set objWord = CreateObject("Word.Application")
Resume
End Sub
Das is wirklich komisch, nach weiteren Durchläufen führt er den Code tatsächlich aus.
Nur leider erzielt das auch nicht die gewünschte Wirkung.
Das Öffnen des Dokuments dauert leider genau so lange :(
Gruß
Hallo,
tut mir leid, dann werfe ich das Handtuch.
Moin,
lege doch einfach einmal zum Test einige der Files lokal ab. Dauert es ann auch so lange, oder ist das Netzwerk die Engstelle im Flaschenhals?
Hallo,
leider habe ich das auch schon versucht und es brachte keinen Erfolg...
Gruß