Keywords bei mehreren *.doc ergänzen

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Keywords bei mehreren *.doc ergänzen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread