'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
