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
Sub RemoveAllSpeakerNotes()
Dim sld As Slide
For Each sld In ActivePresentation.Slides
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = ""
Next sld
End Sub