VBA批量修改ppt文件的属性（作者、主题、标题、关键字等信息）
Option ExplicitDim 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，但是没有修改成功，有会的大师帮助下小弟，不胜感激！~{:5_203:} {:5_203:} {:5_203:} {:5_203:} {:5_203:} {:5_203:} 自己搞的了，原来修改后关闭之前没有保存
End With
oDoc.save
oDoc.Close
Next
页:
[1]