VBA批量修改ppt文件的属性（作者、主题、标题、关键字等信息）

nimrod2008

Option Explicit

Dim ArrFiles(1 To 10000)
Dim cntFiles%

Sub SetDocss()

'Dim myPageSetup As PageSetup

'Dim myDialog As FileDialog

Dim oFile As Variant

Dim FolderPath As String

Dim oDoc As Presentation

'Dim rngHeaders As Range

'Dim rngFooters As Range

'Dim myRange As Range

'Dim docCount As Integer

Dim myTitle As String

Dim mySubject As String

Dim myAuthor As String

Dim myManager As String

Dim myCompany As String

Dim myComments As String

Dim mykeyWords As String

Dim mycategory As String

Dim lastauthor As String




On Error Resume Next

'以下定义文档属性

myTitle = "http://www.XXXXs.com"

mySubject = "http://www.XXXs.com"

myAuthor = "http://www.XXXs.com"

myManager = "http://www.XXXs.com"

myCompany = "http://www.XXXs.com"

myComments = "http://www.XXXs.com"

mykeyWords = "http://wwws.com"

mycategory = "http://www.XXXs.com"

lastauthor = "http://www.XXXs.com"

Dim Rsp
Dim strPath$
'Dim i%
'Set fso = CreateObject("Scripting.FileSystemObject")
Dim fso As New FileSystemObject, fd As Folder
strPath = InputBox("请输入要修改的文件夹地址,以\结尾:", "")
cntFiles = 0
Set fd = fso.GetFolder(strPath)
SearchFiles fd

Rsp = MsgBox("共有ppt文件" & cntFiles & "个，确定要修改", vbYes)
'Application.ScreenUpdating = False


For Each oFile In ArrFiles
'在所有选取项目中循环
Set oDoc = Presentations.Open(FileName:=oFile, WithWindow:=msoFalse)



With oDoc.BuiltInDocumentProperties

.Item("title").Value = myTitle

.Item("subject").Value = mySubject

.Item("author").Value = myAuthor

.Item("manager").Value = myManager

.Item("company").Value = myCompany

.Item("comments").Value = myComments

.Item("keywords").Value = mykeyWords

.Item("category").Value = mycategory

.Item("timelastsaved").Value = lastauthor

End With

oDoc.Close

Next


'End With

End Sub
Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
If UCase(Right(Trim(fl), 3)) = "PPT" Then
cntFiles = cntFiles + 1
ArrFiles(cntFiles) = fl.Path
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub

For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub
'----------------------
大家看看有什么问题，就是修改不成功...
我认为主要是
.Item("title").Value = myTitle这部分的事，在word中是.Item(wdPropertyTitle) = myTitle这样实现的，但是不知道ppt中是啥，阅读这个帮助如果演示文稿的作者为“Jake Jarmel”，本示例为该文稿设定内置文档属性“Category”的值。

With Application.ActivePresentation.BuiltInDocumentProperties
    If .Item("author").Value = "Jake Jarmel" Then
        .Item("category").Value = "Creative Writing"
    End If
End With
改用.Item("title").Value = myTitle，但是没有修改成功，有会的大师帮助下小弟，不胜感激！~

nimrod2008

自己搞的了，原来修改后关闭之前没有保存
End With
oDoc.save
oDoc.Close

Next