Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1912to1916
1912to1916
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Keywords bei mehreren *.doc ergänzen

Forumthread: Keywords bei mehreren *.doc ergänzen

Keywords bei mehreren *.doc ergänzen
22.12.2022 14:49:17
christoph.essen@gmx.de
Hallo liebes Forum,
vielleicht könnte Ihr mir helfen?
Ich habe in Excel eine Liste mit UNC Pfaden zu Dokumenten. Bei diesen Dokumenten habe ich schon alle Dokumenteneigenschaft ausgelesen (vor allem Titel, Keywords, ...).
Nun soll der Nutzer aber die Möglichkeit haben, den TITEL und die KEYWORDS der Dokumenteneigenschaft (z.T. auch Markierungen genannt) zu ergänzen oder anzupassen.
Mit ist bekannt, dass dies bei NICHT-Office Dokumenten (z.B. odt von libir office oder open office) nicht geht. Aber ist dies denn bei Office Dokumenten möglich? Am liebsten natürlich OHNE die Datei zu öffnen. Zur Not aber auch in dem das Dokument kurz geöffnet, verändert und dann wieder geschlossen wird.
Um es konreter zu machen... In Spalte A soll der Dateipfad stehen (mit Dateinamen) und in Spalte B der "neue" Titel und in Spalte C das "neue"/"ergänzte" Keyword (die werden meines Wissens nach als Array gespeichert).
Wer kann mir helfen?
1000 DANK und VLG
Anzeige

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 15:51:27
Fennek
Hallo,
früher gab es für diesen Zweck von M$ "DsoFile", mittlerweile wird aber wegen Schwachstellen davon abgeraten.
Ebenso ist ein PyPi-Projekt eher supekt.
Das Öffnen einer Word-Datei geht in VBA so einfach, dass es wenig Sinn macht, das vermeiden zu wollen.
mfg
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 17:37:51
snb 

Sub M_snb()
c00 = Dir("G:\OF\*.doc")
With GetObject("G:\OF\" & c00)
.BuiltinDocumentProperties("title") = "neu"
.BuiltinDocumentProperties("Keywords") = .BuiltinDocumentProperties("Keywords") & ", ganz neu"
.Save
.Close 0
End With
End Sub

Anzeige
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 19:54:28
christoph.essen@gmx.de
Hallo snb,
DANKE schön... MEGA !!!
Bei close 0 hat es sich bei der 2. Runde der Schleife aufgehängt: "Laufzeitferhler '450': Falsche Anahl an Argumenten oder ungültige Zuweisung zu einer Eigentschaft."
Habe es also ohne der 0 probiert und es klappt !!! PERFEKT....
Kannst Du mir sagen, für was für Dateien das geht? Nur für Office vermutlich, richtig?
VLG und DANKE
Anzeige
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 20:33:23
christoph.essen@gmx.de
Mein Teil ist sicherlich nicht sehr elegant programmiert... Nehme gerne Tipps an. Aber ich habe zumindest noch ergänzt, dass der Fehler angefangen wird, falls sich das Attribut in NICHT-Office Dateien nicht ändern lässt :-)
DANKE nochmals an snb

Option Explicit
Sub Titel_Keywords_Anpassen()
Dim File_Name, File_Type As String
Dim v As Integer
On Error GoTo err_exit
v = 4 ' Zeilen-Index
' Für jede Zeile
Do Until Worksheets(1).Cells(v, 1) = ""
' Nur wenn Änderungen eingetragen sind, sollen der TITEL oder die KEYWORDS neu beschrieben werden
If Worksheets(1).Cells(v, 5)  "" Or Worksheets(1).Cells(v, 7)  "" Then
' Welche Datei soll geöffnet werden?
File_Name = Worksheets(1).Cells(v, 3).Value
File_Type = Right(File_Name, InStr(1, StrReverse(File_Name), "."))
If File_Type  "" Then  'um Ordner abzufangen, die auch in der Liste stehen können
' Für jede Zeile...
With GetObject(File_Name)
' Änderung eingetragen also gewünscht? --> Dann ändern
If Worksheets(1).Cells(v, 5).Value  "" Then .BuiltinDocumentProperties("Title") = Worksheets(1).Cells(v, 5).Value
If Worksheets(1).Cells(v, 7).Value  "" Then .BuiltinDocumentProperties("Keywords") = Worksheets(1).Cells(v, 7).Value
.Save
' Check ob Eintragung geklappt hat...
If Worksheets(1).Cells(v, 5).Value = .BuiltinDocumentProperties("Title") Then
Worksheets(1).Cells(v, 4).Value = .BuiltinDocumentProperties("Title")
Worksheets(1).Cells(v, 5).Value = ""
End If
If Worksheets(1).Cells(v, 7).Value = .BuiltinDocumentProperties("Keywords") Then
Worksheets(1).Cells(v, 6).Value = .BuiltinDocumentProperties("Keywords")
Worksheets(1).Cells(v, 7).Value = ""
End If
.Close
End With
End If
End If
sprung:
v = v + 1
Loop
MsgBox ("FERTIG!")
Exit Sub
' Fehlerabfangen, falls Doc.Typ nicht verändert werden kann, also für NICHT-Office Dateien
err_exit:
Worksheets(1).Cells(v, 5).Value = File_Type & " >>> keine MS-OFFICE Datei >>> Änderung geht nur in der entsprecpassenden Anwendung selbst"
Worksheets(1).Cells(v, 7).Value = File_Type & " >>> keine MS-OFFICE Datei >>> Änderung geht nur in der entsprecpassenden Anwendung selbst"
Resume sprung
End Sub

Anzeige
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 20:54:42
christoph.essen@gmx.de
Mein Teil ist sicherlich nicht sehr elegant programmiert... Nehme gerne Tipps an. Aber ich habe zumindest noch ergänzt, dass der Fehler angefangen wird, falls sich das Attribut in NICHT-Office Dateien nicht ändern lässt :-)
DANKE nochmals an snb

Option Explicit
Sub Titel_Keywords_Anpassen()
Dim File_Name, File_Type As String
Dim v As Integer
On Error GoTo err_exit
v = 4 ' Zeilen-Index
' Für jede Zeile
Do Until Worksheets(1).Cells(v, 1) = ""
' Nur wenn Änderungen eingetragen sind, sollen der TITEL oder die KEYWORDS neu beschrieben werden
If Worksheets(1).Cells(v, 5)  "" Or Worksheets(1).Cells(v, 7)  "" Then
' Welche Datei soll geöffnet werden?
File_Name = Worksheets(1).Cells(v, 3).Value
File_Type = Right(File_Name, InStr(1, StrReverse(File_Name), "."))
If File_Type  "" Then  'um Ordner abzufangen, die auch in der Liste stehen können
' Für jede Zeile...
With GetObject(File_Name)
' Änderung eingetragen also gewünscht? --> Dann ändern
If Worksheets(1).Cells(v, 5).Value  "" Then .BuiltinDocumentProperties("Title") = Worksheets(1).Cells(v, 5).Value
If Worksheets(1).Cells(v, 7).Value  "" Then .BuiltinDocumentProperties("Keywords") = Worksheets(1).Cells(v, 7).Value
.Save
' Check ob Eintragung geklappt hat...
If Worksheets(1).Cells(v, 5).Value = .BuiltinDocumentProperties("Title") Then
Worksheets(1).Cells(v, 4).Value = .BuiltinDocumentProperties("Title")
Worksheets(1).Cells(v, 5).Value = ""
End If
If Worksheets(1).Cells(v, 7).Value = .BuiltinDocumentProperties("Keywords") Then
Worksheets(1).Cells(v, 6).Value = .BuiltinDocumentProperties("Keywords")
Worksheets(1).Cells(v, 7).Value = ""
End If
.Close
End With
End If
End If
sprung:
v = v + 1
Loop
MsgBox ("FERTIG!")
Exit Sub
' Fehlerabfangen, falls Doc.Typ nicht verändert werden kann, also für NICHT-Office Dateien
err_exit:
Worksheets(1).Cells(v, 5).Value = File_Type & " >>> keine MS-OFFICE Datei >>> Änderung geht nur in der entsprecpassenden Anwendung selbst"
Worksheets(1).Cells(v, 7).Value = File_Type & " >>> keine MS-OFFICE Datei >>> Änderung geht nur in der entsprecpassenden Anwendung selbst"
Resume sprung
End Sub

Anzeige
AW: Keywords bei mehreren *.doc ergänzen
22.12.2022 22:15:06
snb
Nur für Office Dateien.
Also: lösche in Spalte C alle nicht Office Dateien bevor du diesen Makro laufen lasst.

Sub M_snb()
sn = Sheets(1).CurrentRegion
For j = 4 To UBound(sn)
If sn(j, 5) & sn(j, 7)  "" And Right(sn(j, 3), 1)  "." Then
With GetObject(sn(j, 3))
If sn(j, 5)  "" Then .BuiltinDocumentProperties("Title") = sn(j, 5)
If sn(j, 7)  "" Then .BuiltinDocumentProperties("Keywords") = sn(j, 7)
.Save
.Close 0
End With
End If
Next
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige