Dokumenteigenschaften auslesen dauert

[Nelloz]

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ß!

[Steffl]

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 


[Nelloz]

Hallo Stefan,

danke erstmal für den Hinweis.
Leider dauert es immer gleichlang, auch beim ersten Durchlauf des Loops.

Gruß

[Steffl]

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

[Nelloz]

Damit bekomme ich leider in der Zeile

Code:

Set objWord = GetObject(, "Word.Application")

den Laufzeitfehler "Objekterstellung durch ActiveX Komponente nicht möglich"

[Steffl]

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

[Nelloz]

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ß

[Steffl]

Hallo,

tut mir leid, dann werfe ich das Handtuch.

[GMG-CC]

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?

[Nelloz]

Hallo,

leider habe ich das auch schon versucht und es brachte keinen Erfolg...


Gruß