Dokumenteigenschaften von mehreren Word-Dokumenten löschen

Dieses Thema Dokumenteigenschaften von mehreren Word-Dokumenten löschen im Forum "Microsoft Office Suite" wurde erstellt von kukris, 19. Mai 2007.

Thema: Dokumenteigenschaften von mehreren Word-Dokumenten löschen Hallo, ich suche ein Programm / Makro, daß aus mehreren Word-Dokumenten die Dokumenteigenschaften löschen...

  1. Hallo,

    ich suche ein Programm / Makro, daß aus mehreren Word-Dokumenten die Dokumenteigenschaften löschen (Word-->Datei-->Eigenschaften) kann.

    Kennt jemand so etwas? (Ab Word 2000)

    Gruß

    Kukris
     
  2. Hallo kurkis,

    ich hab dir eine Beispiel-Function Word_DocPropertiesDelete geschrieben, die im übergebenen Document die Dokument-Eigenschaften löscht.

    Die Sub Test_DOKEIGENCHAFTENLOESCHEN() zeigt, wie die Fuction für das aktuelle Dokument aufgerufen wird. Das kann man dann erweitern .

    Um mehrere Datein auszuwählen, kann man den Windows-Datei-Dialog einbauen.

    Siehe auch http://www.wintotal-forum.de/index.php/topic,96825.0.html

    Gruß Matjes :)

    Code:
    Sub Test_DOKEIGENCHAFTENLOESCHEN()
      Dim doc As Document
      Set doc = ActiveDocument
      Call Word_DocPropertiesDelete(doc)
    AUFRAEUMEN:
      Set doc = Nothing
    End Sub
    '*********************************************
    Function Word_DocPropertiesDelete(doc As Document)
    
      Dim dp As DocumentProperty
      
     ->eingebaute DocProps Value löschen
      On Error Resume Next
      For Each dp In doc.BuiltInDocumentProperties
        If dp.Type = 1 Then->msoPropertyTypeNumber
          dp.Value = 0
        ElseIf dp.Type = 2 Then->msoPropertyTypeBoolean
          dp.Value = Nothing
        ElseIf dp.Type = 3 Then->msoPropertyTypeDate
          dp.Value = Nothing
        ElseIf dp.Type = 4 Then->msoPropertyTypeString
          dp.Value = 
        ElseIf dp.Type = 5 Then->msoPropertyTypeFloat
          dp.Value = 0
        End If
      Next
      On Error GoTo 0
      
     ->selbsterzeugte DocProps löschen
      For Each dp In doc.CustomDocumentProperties: dp.Delete: Next
      
    AUFRAEUMEN:
      Set dp = Nothing
    End Function
     
  3. Hallo Matjes,

    vielen Dank für den Code. Sobald ich Zeit habe probiere ich das aus und melde mich wieder.
     
  4. Hallo,

    ich habe jetzt wieder etwas Zeit gefunden und habe den Öffnen-Dialog von folgendem Beitrag verwendet(http://www.wintotal-forum.de/index.php/topic,114988.msg593446.html), aber nun bekomme ich beim Ausführen den Fehler Argumenttyp unverträglich. Kann mir hier jemand helfen?

    Code:
    Option Explicit
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
    Private Type BrowseInfo
      hOwner     As Long
      pidlRoot    As Long
      pszDisplayName As String
      lpszTitle    As String
      ulFlags     As Long
      lpfn      As Long
      lParam     As Long
      iImage     As Long
    End Type
    
    Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    
    Sub main_DelDocProps()
    
     Dim i As Long, ret As Integer, sDateiname As String
     Dim sPfad As String, sDateinameFull As String, bSubFolders As Boolean
     
    ->Wurzelverzeichnis abfragen
     sPfad = VerzeichnisWaehlen(Quellverzeichnis auswählen)
     If sPfad =  Then Exit Sub-> Abbruch ?
     
    ->Abfrage mit/ohne Sub-Directories
     ret = MsgBox( _
      Sollen die Unterverzeichnisse einbezogen werden?, _
      vbYesNoCancel + vbDefaultButton2 + vbQuestion, _
      Auswahl mit/ohne Unterverzeichnisse)
     If ret = vbYes Then
      bSubFolders = True
     ElseIf ret = vbNo Then
      bSubFolders = False
     Else
      Exit Sub->Abbruch
     End If
    
     Application.ScreenUpdating = False
     
    ->Dateien suchen
     With Application.FileSearch
      .NewSearch
      .LookIn = sPfad
      .SearchSubFolders = bSubFolders
      .FileType = msoFileTypeWordDocuments
      .Execute
     ->alle gefundenen Dateien
      For i = 1 To .FoundFiles.Count
       sDateinameFull = .FoundFiles(i)
       sDateiname = DateinameAusDateinameFull(sDateinameFull)
      ->Datei gleichen Namens wie die Makro-Datei von Konvertierung ausschliessen
      ->If LCase(ThisWorkbook.Name) <> LCase(sDateiname) Then
        Application.StatusBar = sDateinameFull
       ->Dateieigenschaften löschen
        If Not Word_DocPropertiesDelete(sDateinameFull) Then
         MsgBox Fehler bei der Ausführung. & vbLf & sDateinameFull
        End If
        Application.StatusBar = 
        DoEvents
       End If
      Next
     End With
     
     Application.ScreenUpdating = True
    End Sub
    
    
    
    '***********************************************************
    Private Function VerzeichnisWaehlen(Optional DialogTitel) As String
    '***********************************************************
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
      Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
      Dim hWndAccessApp As Long
     
      With StrukturVerzeichnisInfo
        .hOwner = hWndAccessApp
        .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
        .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
      End With
      
      ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
      Pfad = Space$(512)
      
      If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWaehlen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
      
    End Function
    
    
    
    '***********************************************************
    Private Function DateinameAusDateinameFull(sDateinameFull As String) As String
    '***********************************************************
     Dim pos As Long, posx As Long
     pos = 0: posx = 0
     Do
      pos = InStr(pos + 1, sDateinameFull, Application.PathSeparator)
      If pos > 0 Then posx = pos
     Loop While pos <> 0
     If posx = 0 Then
      DateinameAusDateinameFull = sDateinameFull
     Else
      DateinameAusDateinameFull = Right(sDateinameFull, Len(sDateinameFull) - posx)
     End If
     
    End Function
    
    
    
    '*************************************************
    Function Word_DocPropertiesDelete(doc As Document)
    
     Dim dp As DocumentProperty
     
    ->eingebaute DocProps Value löschen
     On Error Resume Next
     For Each dp In doc.BuiltInDocumentProperties
      If dp.Type = 1 Then->msoPropertyTypeNumber
       dp.Value = 0
      ElseIf dp.Type = 2 Then->msoPropertyTypeBoolean
       dp.Value = Nothing
      ElseIf dp.Type = 3 Then->msoPropertyTypeDate
       dp.Value = Nothing
      ElseIf dp.Type = 4 Then->msoPropertyTypeString
       dp.Value = 
      ElseIf dp.Type = 5 Then->msoPropertyTypeFloat
       dp.Value = 0
      End If
     Next
     On Error GoTo 0
     
    ->selbsterzeugte DocProps löschen
     For Each dp In doc.CustomDocumentProperties: dp.Delete: Next
     
    AUFRAEUMEN:
     Set dp = Nothing
    End Function
    
     
  5. Hallo kurkis,

    probiers mal so: Datei öffnen, Datei bearbeiten, Datei schliessen ;)

    Gruß Matjes :)
     
  6. Hallo Matjes,

    vielen Dank für den richtigen Code. Funktioniert jetzt alles einwandfrei

    Gruß

    kukris
     
  7. Leider ist noch ein Problem aufgetaucht: Es werden leider nicht nur Word-Dateien, sondern seltsamerweise auch HTML-Dateien geöffnet, was jedoch zu einem Fehler führt. Das Makro bleibt dann stehen.

    Ist es möglich den Dateityp explizit auf *.doc zu filtern?
     
  8. Hallo kukris,

    dann mit Filter nur *.doc.

    Gruß Matjes :)
     
  9. Hallo Matjes,

    vielen Dank. Funktioniert jetzt einwandfrei und ist ohne Fehler durchgelaufen.

    Gruß

    Kukris
     
  10. Hallo,

    ich habe jetzt versucht das ganze auch für Excel- und PowerPoint-Dokumente zu erstellen. Bei Excel hat es funktioniert, bei PowerPoint jedoch bekomme ich einen Fehler beim Kompilieren und weiß nicht warum. Kann mir jemand sagen warum?

    Code:
    'Delete properties of PowerPoint documents (only *.ppt) like author, comment, etc.
    
    Option Explicit
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
    Private Type BrowseInfo
      hOwner     As Long
      pidlRoot    As Long
      pszDisplayName As String
      lpszTitle    As String
      ulFlags     As Long
      lpfn      As Long
      lParam     As Long
      iImage     As Long
    End Type
    
    Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
    Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    
    Sub main_DelPptProps()
    
     Dim Ppt As PowerPointPresentation
     Dim i As Long, ret As Integer, sDateiname As String
     Dim sPfad As String, sDateinameFull As String, bSubFolders As Boolean
     
    ->Wurzelverzeichnis abfragen
     sPfad = VerzeichnisWaehlen(Quellverzeichnis auswählen)
     If sPfad =  Then Exit Sub-> Abbruch ?
     
    ->Abfrage mit/ohne Sub-Directories
     ret = MsgBox( _
      Sollen die Unterverzeichnisse einbezogen werden?, _
      vbYesNoCancel + vbDefaultButton2 + vbQuestion, _
      Auswahl mit/ohne Unterverzeichnisse)
     If ret = vbYes Then
      bSubFolders = True
     ElseIf ret = vbNo Then
      bSubFolders = False
     Else
      Exit Sub->Abbruch
     End If
    
     Application.ScreenUpdating = False
     
    ->Dateien suchen
     With Application.FileSearch
      .NewSearch
      .LookIn = sPfad
      .SearchSubFolders = bSubFolders
      .FileType = msoFileTypePowerPointPresentations
      .Execute
     ->alle gefundenen Dateien
      For i = 1 To .FoundFiles.Count
       sDateinameFull = .FoundFiles(i)
      ->Datei gleichen Namens wie die Makro-Datei von Konvertierung ausschliessen
       If LCase(ThisPowerPointPresentation.FullName) <> LCase(sDateinameFull) Then
        If LCase(Right(sDateinameFull, 4)) = .ppt Then
         Application.StatusBar = sDateinameFull
          
        ->Datei öffnen
         On Error Resume Next
         Set Ppt = PowerPointPresentations.Open(FileName:=sDateinameFull)
    
         On Error GoTo 0
         If Ppt Is Nothing Then
          MsgBox Datei:  & sDateinameFull &  konnte nicht geöffnet werden.
         Else
         ->Dateieigenschaften löschen
          Call PowerPoint_PptPropertiesDelete(Ppt)
         ->speichern und schliessen
          Ppt.Close Savechanges:=True
         
         End If
        
         Application.StatusBar = 
         DoEvents
        End If
       End If
      Next
     End With
     
     Application.ScreenUpdating = True
    AUFRAEUMEN:
     Set Ppt = Nothing
     MsgBox Programmende.
    End Sub
    
    
    
    '***********************************************************
    Private Function VerzeichnisWaehlen(Optional DialogTitel) As String
    '***********************************************************
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
      Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
      Dim hWndAccessApp As Long
     
      With StrukturVerzeichnisInfo
        .hOwner = hWndAccessApp
        .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
        .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
      End With
      
      ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
      Pfad = Space$(512)
      
      If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWaehlen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
      
    End Function
    
    
    
    '***********************************************************
    Private Function DateinameAusDateinameFull(sDateinameFull As String) As String
    '***********************************************************
     Dim pos As Long, posx As Long
     pos = 0: posx = 0
     Do
      pos = InStr(pos + 1, sDateinameFull, Application.PathSeparator)
      If pos > 0 Then posx = pos
     Loop While pos <> 0
     If posx = 0 Then
      DateinameAusDateinameFull = sDateinameFull
     Else
      DateinameAusDateinameFull = Right(sDateinameFull, Len(sDateinameFull) - posx)
     End If
     
    End Function
    
    
    '*************************************************
    Private Function PowerPoint_PptPropertiesDelete(Ppt As PowerPointPresentation) As Boolean
    
     Dim dp As DocumentProperty
    
    ->eingebaute PptProps Value löschen
     On Error Resume Next
     For Each dp In Ppt.BuiltInDocumentProperties
      If dp.Type = 1 Then->msoPropertyTypeNumber
       dp.Value = 0
      ElseIf dp.Type = 2 Then->msoPropertyTypeBoolean
       dp.Value = Nothing
      ElseIf dp.Type = 3 Then->msoPropertyTypeDate
       dp.Value = Nothing
      ElseIf dp.Type = 4 Then->msoPropertyTypeString
       dp.Value = 
      ElseIf dp.Type = 5 Then->msoPropertyTypeFloat
       dp.Value = 0
      End If
     Next
     On Error GoTo 0
    
    ->selbsterzeugte PptProps löschen
     For Each dp In Ppt.CustomDocumentProperties: dp.Delete: Next
    
    AUFRAEUMEN:
     Set dp = Nothing
    End Function
    
     
Die Seite wird geladen...

Dokumenteigenschaften von mehreren Word-Dokumenten löschen - Ähnliche Themen

Forum Datum
Excel Tabellen erstellen mit mehreren Prüfungen Microsoft Office Suite 28. Juli 2015
Darstellung auf mehreren Bildschirmen Windows 7 Forum 15. Mai 2015
Benutzerdaten auf mehreren Laufwerken Windows 7 Forum 13. Sep. 2014
Checkdisk beim hochfahren auf mehreren Rechner Windows 7 Forum 22. Apr. 2013
Brauche Hilfe beim Benutzen von DreamScene bei mehreren Monitorn Software: Empfehlungen, Gesuche & Problemlösungen 28. Nov. 2010