VBA macro to convert old PowerPoint .ppt file format to new .pptx format, without compatibility mode, and embed the multimedia files.

PowerPoint-convert-to-new-file-format.vba

' Main function: ActiveToNewFormat, convert the file to new format
' Reference: (TODO add reference)
' License: GNU GPL v3 or later


Function GetNoSuffix() As String
    Dim name As String
    name = ActivePresentation.FullName ' a/b.c
    
    pos = InStrRev(name, ".")
    GetNoSuffix = Left(name, pos - 1) ' a/b

End Function

Function GetSuffix() As String
    Dim name As String
    name = ActivePresentation.FullName ' a/b.c
    
    pos = InStrRev(name, ".")
    GetSuffix = Right(name, Len(name) - pos) ' c
End Function

Sub ActiveConvert2()
    ActivePresentation.Save

    Dim name As String
    name = ActivePresentation.FullName ' a/b.c

    nosuffix = GetNoSuffix()
    pos = InStrRev(nosuffix, "\")
    par = Left(nosuffix, pos) ' a/
    stem = Right(nosuffix, Len(nosuffix) - pos) ' b

    Set fso = CreateObject("scripting.filesystemobject")
    fso.CopyFile name, par & "--backup--" & stem & "." & GetSuffix()

    namex = nosuffix & ".pptx"
    ActivePresentation.Convert2 namex

    If LCase(name) <> LCase(namex) Then
        fso.DeleteFile name
    End If
End Sub

Sub ActiveToNewFormat()
    Dim suffix As String
    suffix = GetSuffix()
    If LCase(suffix) <> "ppt" And LCase(suffix) <> "pptx" Then
        MsgBox "Khong phai powerpoint???"
        Exit Sub
    End If
    
    ActiveConvert2

    suffix = ""

    Dim shp As Shape
    Dim sld As Slide

    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes
            
            oldtype = shp.Type
            
            HasError = False
            On Error GoTo cannotbreak
            shp.LinkFormat.BreakLink
            
            If Not HasError Then
                Debug.Print oldtype & "-" & shp.Type
                GoTo nextshp
            End If
            
            If False Then
cannotbreak:
                HasError = True
                Resume Next
            End If
            
            On Error GoTo 0
            'If shp.Type = msoLinkedOLEObject Then
            '    shp.LinkFormat.Update
            '    shp.LinkFormat.BreakLink
            'End If
            
nextshp:
        Next shp
    Next sld

    ActivePresentation.Save
End Sub