标题: [问题求助] 求助，用VBS对PPT文档重命名 [打印本页]

---

作者: hanlei514    时间: 2021-4-26 10:09     标题: 求助，用VBS对PPT文档重命名

今天看到1个WORD文档的重命名，内容如下：
Option Explicit
Const g_strRootPath = "C:\Users\Administrator\Desktop\新建文件夹\word\"
Const g_nTitleMaxLen = 30
Call Main

Sub Main()
Dim fso, oFolder, oWordApp
Set oWordApp = CreateObject("Word.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(g_strRootPath)
RenameDocFilesUnderFolder oWordApp, fso, oFolder
oWordApp.Quit
Set oWordApp = Nothing
MsgBox "完成！"
end Sub



Sub RenameDocFilesUnderFolder(oWordApp, fso, oFolder)
Dim oSubFolder, oFile, oDoc
Dim strTitle, strFileName
For Each oSubFolder In oFolder.SubFolders
RenameDocFilesUnderFolder oWordApp, fso, oSubFolder
next
For Each oFile In oFolder.Files
Set oDoc = oWordApp.Documents.Open(oFile.Path)
strTitle = GetFirstVisibleTextContent(oDoc)
oDoc.Close
Set oDoc = Nothing
If Len(strTitle) <> 0 Then
strFileName = fso.BuildPath(fso.GetParentFolderName(oFile.Path), strTitle & "." & fso.GetExtensionName(oFile.Path))
strFileName = GetUniqueFileName(fso, strFileName)
fso.MoveFile oFile.Path, strFileName
end If
next
end Sub


Function GetFirstVisibleTextContent(oDoc)
Dim oParagraph
Dim strContent
For Each oParagraph In oDoc.Paragraphs
strContent = GetSafeFileName(oParagraph.Range.Text)
If Len(strContent) <> 0 Then
GetFirstVisibleTextContent = strContent
Exit Function
end If
next
GetFirstVisibleTextContent = ""
end Function


Function GetSafeFileName(strFileName)
Dim arrUnsafeCharacters, strUnsafeChar
Dim nIndex
arrUnsafeCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
For nIndex = 0 To &H2F
strFileName = Replace(strFileName, Chr(nIndex), "")
next
For Each strUnsafeChar In arrUnsafeCharacters
strFileName = Replace(strFileName, strUnsafeChar, "")
next
GetSafeFileName = left(Trim(strFileName), g_nTitleMaxLen)
end Function


Function GetUniqueFileName(fso, strFullName)
Dim strParentFolder, strBaseName, strExtensionName
Dim nIndex
If Not fso.FileExists(strFullName) Then
GetUniqueFileName = strFullName
Exit Function
end If
strParentFolder = fso.GetParentFolderName(strFullName)
strBaseName = fso.GetBaseName(strFullName)
strExtensionName = fso.GetExtensionName(strFullName)
nIndex = 0
While fso.FileExists(strFullName)
nIndex = nIndex + 1
strFullName = fso.BuildPath(strParentFolder, strBaseName & "_" & nIndex & "." & strExtensionName)
Wend
GetUniqueFileName = strFullName
End Function

执行后效果很好，想PPT有没有这样的功能？ 另外想请教下，如果将网上找到宏命令和VBS脚本结合在一起？  比如我在网上找到一个PPT宏命令：

Sub RemoveAllSpeakerNotes()
    Dim sld As Slide
    For Each sld In ActivePresentation.Slides
        sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = ""
    Next sld
End Sub

每次运行这个宏代码，我都要打开PPT去执行，怎么才能像上面那样，做成一个.vbs文件直接点一下就能把指定文件夹的PPT做这个宏命令运行呢？

---

欢迎光临 批处理之家 (http://bbs.bathome.net/)

Powered by Discuz! 7.2