Consulting

Results 1 to 6 of 6

Thread: Renaming ppt file name with Slide#1 tittle name

  1. #1
    VBAX Newbie
    Joined
    Mar 2017
    Posts
    1
    Location

    Renaming ppt file name with Slide#1 tittle name

    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(msoTextOrientationHorizontal, _
            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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    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!

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  6. #6
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •