Renaming ppt file name with Slide#1 tittle name

[Guie_]

Is it possible to rename ppt files with the tittle (or slide #1 name)?
I have 17 years worth of powerpoint's that I would like to organize. The naming system used was alphanumeric, but it doesn't tell you what the presentation was on. I would love to clean this up, but I am not sure how to go about it yet, or if there is a better way.

So far the code below is the most useful one I found, once I rename all the files. I intend to manipulate it so I can put this in a "Table of content" excel file with hyperlinks.

All help is appreciated, if there are better methods, I would love to hear those as well.


Sub MakeLotsOfLinks()

Dim TheTextBox As Shape
Dim FileName As String
Dim LinkRange As TextRange
Dim Top, Left, width, height As Double
Dim targetFileSpec As String


' EDIT THIS: Replace the text between the equals signs
' with the path to the folder where your PPT files are stored
targetFileSpec = "C:\Users\Guie\Desktop\ppt\2015\*.PPT"


' Rather arbitrary starting positions for text box
Top = 18#
Left = 18#
width = 600#
height = 30#


' Get the first matching file
FileName = Dir$(targetFileSpec)


' And if somebody's home:
While FileName <> ""


' Add a textbox to hold the link
Set TheTextBox = ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHoriz ontal, _
Left, _
Top, _
width, _
height)


TheTextBox.TextFrame.TextRange.Text = FileName


Set LinkRange = TheTextBox.TextFrame.TextRange.Characters(Start:=1, Length:=Len(FileName))
LinkRange.ActionSettings(ppMouseClick).Hyperlink.Address = FileName


' Get the next file
FileName = Dir$
' move the text box start position down
Top = Top + height
Wend


End Sub

[John Wilson]

Looks like there are two questions here.

Rename files
Create an index

There are several gotchas in renaming based on the title:


The title may have characters which are not allowed as file names (\ / * ? | " < >)
There may be duplicate file names (which will fail)
The slide may not have a title at all or no text.

This will solve the duplicate problem (maybe) by adding the time saved last and hopefully prevent duplicate names) and remove non saveable characters


Sub resave()
Dim strDate As string
Dim strFilePath As String
Dim L As Long
Dim iPos As Integer
Dim strName As String
Dim strSuffix As String
Dim oPres As Presentation
Const Folderpath As String = "C:\Users\Optiplex\Desktop\Files\"
Const strSpec As String = "*.ppt*"
On Error Resume Next
MkDir Folderpath & "\Resaved Files"
'First match
strFilePath = Dir$(Folderpath & strSpec)
While strFilePath <> ""
strName = ""
Set oPres = Presentations.Open(FileName:=Folderpath & strFilePath, WithWindow:=False)
iPos = InStrRev(oPres.Name, ".")
strSuffix = Mid(oPres.Name, iPos)
If oPres.Slides(1).Shapes.HasTitle Then
If oPres.Slides(1).Shapes.Title.TextFrame.HasText Then
strName = oPres.Slides(1).Shapes.Title.TextFrame.TextRange
End If
End If
strName = clean(strName)
MsgBox strName
If strName = "" Then strName = "Slide1"
strDate = oPres.BuiltInDocumentProperties("Last save time")
strDate = Format(strDate, "mmm dd yyyy hh_mm")
oPres.SaveCopyAs Folderpath & "Resaved Files\" & strName & strDate & strSuffix
oPres.Close
strFilePath = Dir$
Wend
End Sub


Function clean(strIn As String) As String
Select Case True
Case InStr(strIn, "\") > 0
clean = Replace(strIn, "\", "")
Case InStr(strIn, "/") > 0
clean = Replace(strIn, "/", "")
Case InStr(strIn, "?") > 0
clean = Replace(strIn, "?", "")
Case InStr(strIn, "|") > 0
clean = Replace(strIn, "|", "")
Case InStr(strIn, "*") > 0
clean = Replace(strIn, "*", "")
Case InStr(strIn, "<") > 0
clean = Replace(strIn, "<", "")
Case InStr(strIn, ">") > 0
clean = Replace(strIn, ">", "")
End Select
End Function

[dreamventure]

Hi John,

This is exactly what I need! However, the code you wrote doesn't work for me on PowerPoint Pro Plus 2016.
I have changed Folderpath to the path where all ppt files are located.
Then launched the macros.
It started popping up empty dialog windows with Ok button. When I press Ok, it's popping again and so on and so on - as many times as I have files in that folder.
Then I check Resaved Files folder - all files are renamed like this: "Slide1_last_saved_time.ppt".

I am very new in VBA, so any advice is highly appreciated. Happy Thanksgiving week!

[John Wilson]

See if this works then


Sub resave()Dim strDate As String
Dim strFilePath As String
Dim L As Long
Dim iPos As Integer
Dim strName As String
Dim strSuffix As String
Dim oPres As Presentation
Const Folderpath As String = "C:\Users\John_Dell\Desktop\Files\"
Const strSpec As String = "*.ppt*"
On Error Resume Next
MkDir Folderpath & "\Resaved Files"
'First match
strFilePath = Dir$(Folderpath & strSpec)
While strFilePath <> ""
strName = ""
Set oPres = Presentations.Open(FileName:=Folderpath & strFilePath, WithWindow:=False)
iPos = InStrRev(oPres.Name, ".")
strSuffix = Mid(oPres.Name, iPos)
strName = Left(oPres.Name, iPos - 1)
strName = clean(strName)
MsgBox strName
If strName = "" Then strName = "Slide1"
strDate = oPres.BuiltInDocumentProperties("Last save time")
strDate = Format(strDate, "mmm dd yyyy hh_mm")
oPres.SaveCopyAs Folderpath & "Resaved Files\" & strName & strDate & strSuffix
oPres.Close
strFilePath = Dir$
Wend
End Sub




Function clean(strIn As String) As String
clean = strIn
Select Case True
Case InStr(strIn, "\") > 0
clean = Replace(strIn, "\", "")
Case InStr(strIn, "/") > 0
clean = Replace(strIn, "/", "")
Case InStr(strIn, "?") > 0
clean = Replace(strIn, "?", "")
Case InStr(strIn, "|") > 0
clean = Replace(strIn, "|", "")
Case InStr(strIn, "*") > 0
clean = Replace(strIn, "*", "")
Case InStr(strIn, "<") > 0
clean = Replace(strIn, "<", "")
Case InStr(strIn, ">") > 0
clean = Replace(strIn, ">", "")
End Select
End Function

[John Wilson]

Or maybe


Sub resave()

Dim strDate As String
Dim strFilePath As String
Dim L As Long
Dim iPos As Integer
Dim strName As String
Dim strSuffix As String
Dim oPres As Presentation
Const Folderpath As String = "C:\Users\John_Dell\Desktop\Files\"
Const strSpec As String = "*.ppt*"
On Error Resume Next
MkDir Folderpath & "\Resaved Files"
'First match
strFilePath = Dir$(Folderpath & strSpec)
While strFilePath <> ""
strName = ""
Set oPres = Presentations.Open(FileName:=Folderpath & strFilePath, WithWindow:=False)
iPos = InStrRev(oPres.Name, ".")
strSuffix = Mid(oPres.Name, iPos)
strName = oPres.Slides(1).Shapes.Title.TextFrame.TextRange
strName = clean(strName)


If strName = "" Then strName = "Slide1"
strDate = oPres.BuiltInDocumentProperties("Last save time")
strDate = Format(strDate, "mmm dd yyyy hh_mm")
oPres.SaveCopyAs Folderpath & "Resaved Files\" & strName & strDate & strSuffix
oPres.Close
strFilePath = Dir$
Wend
End Sub








Function clean(strIn As String) As String
clean = strIn
Select Case True
Case InStr(strIn, "\") > 0
clean = Replace(strIn, "\", "")
Case InStr(strIn, "/") > 0
clean = Replace(strIn, "/", "")
Case InStr(strIn, "?") > 0
clean = Replace(strIn, "?", "")
Case InStr(strIn, "|") > 0
clean = Replace(strIn, "|", "")
Case InStr(strIn, "*") > 0
clean = Replace(strIn, "*", "")
Case InStr(strIn, "<") > 0
clean = Replace(strIn, "<", "")
Case InStr(strIn, ">") > 0
clean = Replace(strIn, ">", "")
End Select
End Function

[dreamventure]

THANKS A TON!! The second one works. There were a few ppt files not processed well, because they contained VT (vertical tab) symbol. I have renamed them manually.