PPT2000: Sample Code to Batch Save a Group of Presentations as HTML (265050)

MORE INFORMATION

Microsoft provides programming examples for illustration only, without warranty either expressed or implied. This includes, but is not limited to, the implied warranties of merchantability or fitness for a particular purpose. This article assumes that you are familiar with the programming language that is being demonstrated and with the tools that are used to create and to debug procedures. Microsoft support engineers can help explain the functionality of a particular procedure, but they will not modify these examples to provide added functionality or construct procedures to meet your specific requirements. The following macro uses the Microsoft Scripting RunTime reference. You must select this reference for the macro to work properly. If you do not select this reference, you receive a compile error when you run the macro.

1. In PowerPoint, open the Visual Basic Editor (press ALT+F11).
2. On the Tools menu, click References.
3. Click to select the Microsoft Scripting Runtime check box in the list of available references.
4. In the Code window, type the following code:

Sub PptWebSaveBatch()

    'You must enable Microsoft Scripting RunTime in References on the Tools 
    'menu for this macro to work.
    Dim fso As New FileSystemObject
    Dim folSource As Folder
    Dim folDest As Folder
    Dim fil As File
    Dim pres As PowerPoint.Presentation
    Dim sFileName As String
    Dim iFileCount As Integer
    Dim strFolder As String
    
    'Error trapping
    On Error GoTo err_ErrorTrapSaveAs
    Err.Clear

    'Get source folder from user.
DoItAgain:
    strFolder = GetFolderFromUser("Source")
    
    'Verify that source folder exists.
    If fso.FolderExists(strFolder) Then
        Set folSource = fso.GetFolder(strFolder)
    Else
        'Folder does not exist, request it again.
        MsgBox "Folder does not exist"
        GoTo DoItAgain
    End If
    
    strFolder = ""
    
    'Get destination folder from user.
DoItAgain2:
    strFolder = GetFolderFromUser("Destination")
    
    'Verify that destination folder exists.
    If fso.FolderExists(strFolder) Then
        Set folDest = fso.GetFolder(strFolder)
    Else
        'Folder does not exist, request folder again.
        MsgBox "Folder does not exist"
        GoTo DoItAgain2
    End If
    
    'Loop through each file in the source folder.
    For Each fil In folSource.Files
        'Check the extension to see if it is a PowerPoint presentation.
        If LCase(Right(fil.Name, 3)) = "ppt" Then
            
            ' If it is a PowerPoint presentation, open it.
            Set pres = PowerPoint.Presentations.Open(FileName:=folSource & "\" & fil.Name, _
                            ReadOnly:=True)
            
            ' Then save it in the destination folder as HTML.
            pres.SaveAs folDest.Path & "\" & Left(fil.Name, Len(fil.Name) - 4), ppSaveAsHTML
            
            'Then close the presentation.
            pres.Close
            Set pres = Nothing
        End If        

    Next fil
    
Exit Sub

    
'Error trapping code
err_ErrorTrapSaveAs:
    ' Display a message box with the error description and number.
    MsgBox Err.Description, vbInformation, "Error #: " & Err.Number
End Sub

'Function to get folder locations and insert final "\" as needed.
Function GetFolderFromUser(strFolderType As String) As String
    Dim strFolder As String
    
    'Get folder path from user and assign it to strFolder.
    strFolder = InputBox("What is the " & strFolderType & " folder?")
    
    'Make sure that user typed something.
    If strFolder = "" Then End
    
    'Make sure the final backslash is on the string.
    If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
    End If
    
    GetFolderFromUser = strFolder
End Function