Mitgabe von Eigenschaften an versch. Dateiarten

hallo,
ich habe folgendes Problem.
Und zwar will ich verschiedenen dateien und verschiedenen dateiarten benutzerdefinierte eigenschaften mitgeben.
Dazu habe ich folgenden Code gefunden der auch funktioniert, wenn man ihn nur auf das aktuelle Workbook beziehen will:
ActiveWorkbook.CustomDocumentProperties.Add _
Name:="Jahr", LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=2014
Da ich mit meinem Programm aber andere dateien (Excel, pdf, PowerPoint) ansprechen will und nicht das ActiveWorkbook, wird es problematisch.
Folgende idee kam mir bis jetzt: die gewünschte datei öffnen, somit wird diese zum activeworkbook, anschließend die eigenschaften hinzufügen, und zum schluss die gewünschte dateo mit hinzugefügten eigenschaften wieder schließen.
Dieses Vorgehen hat aber viele nachteile, wie z.B. die Laufzeit wird enorm verlängert und das ganze wird auf Excel-dateien beschränkt.
Wie kann ich den Code also anpassen, damit ich verschiedene dateiarten (Excel, pdf, pp) damit ansprechen kann?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ela,
Mal als Ansatz (in einem Standardmodul von XL):

Option Explicit
Sub DocuPropertiesInMSDocs()
Dim objPPApp As Object  ' PowerPoint Application
Dim objPPFile As Object ' PowerPoint Document
Dim objWWApp As Object  ' WinWord Application
Dim objWWFile As Object ' WinWord Document
Dim wbXL As Workbook    ' Excel Workbooks
Dim sDirName As String  ' Verzeichnis
Dim sFileName As String ' Dateiname
' Powerpoint Dateien
Set objPPApp = CreateObject("PowerPoint.Application")
sDirName = "D:\DeinDokumentenVerzeichnis\"
sFileName = Dir(sDirName & "*.ppt*")
Do While sFileName  ""
Application.StatusBar = "Verarbeite " & sFileName & " bitte warten..."
Set objPPFile = objPPApp.Presentations.Open(sDirName & sFileName)
With objPPFile
On Error Resume Next
.CustomDocumentProperties.Add Name:="myNewCDP", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:="mein Test"
If Err.Number  0 Then MsgBox "Fehler in " & sFileName & vbCrLf & _
"Property konnte nicht gesetzt werden!", vbOKOnly +  _
vbExclamation
On Error GoTo 0
.Save
.Close
End With
sFileName = Dir()
Loop
Set objPPApp = Nothing
' WinWord Dateien
Set objWWApp = CreateObject("Word.Application")
sDirName = "D:\DeinDokumentenVerzeichnis\"
sFileName = Dir(sDirName & "*.doc")
Do While sFileName  ""
Application.StatusBar = "Verarbeite " & sFileName & " bitte warten..."
Set objWWFile = objWWApp.Documents.Open(sDirName & sFileName)
With objWWFile
On Error Resume Next
.CustomDocumentProperties.Add Name:="myNewCDP", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:="mein Test"
If Err.Number  0 Then MsgBox "Fehler in " & sFileName & vbCrLf & _
"Property konnte nicht gesetzt werden!", vbOKOnly +  _
vbExclamation
On Error GoTo 0
.Save
.Close
End With
sFileName = Dir()
Loop
Set objWWApp = Nothing
' Excel Dateien
sDirName = "D:\DeinDokumentenVerzeichnis\"
sFileName = Dir(sDirName & "*.xls")
Do While sFileName  ""
Application.StatusBar = "Verarbeite " & sFileName & " bitte warten..."
Set wbXL = Workbooks.Open(sDirName & sFileName)
With wbXL
On Error Resume Next
.CustomDocumentProperties.Add Name:="myNewCDP", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:="mein Test"
If Err.Number  0 Then MsgBox "Fehler in " & sFileName & vbCrLf & _
"Property konnte nicht gesetzt werden!", vbOKOnly +  _
vbExclamation
On Error GoTo 0
.Save
.Close
End With
sFileName = Dir()
Loop
End Sub

Gruess Hansueli

Beliebteste Forumthreads (12 Monate)

Mitgabe von Eigenschaften an versch. Dateiarten

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread