Microsoft KB Archive/265050

= PPT2000: Sample Code to Batch Save a Group of Presentations as HTML =

Article ID: 265050

Article Last Modified on 10/11/2006

-

APPLIES TO


 * Microsoft PowerPoint 2000 Standard Edition

-



This article was previously published under Q265050



SUMMARY
This article contains a sample Microsoft Visual Basic for Applications macro (Sub procedure) that allows you to batch save a group of Microsoft PowerPoint presentations in Hypertext Markup Language (HTML) format.

NOTE: For the following code to work, all of your PowerPoint presentations need to be in a single folder, and their file names should all end in the *.PPT extension.



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(&quot;Source&quot;) 'Verify that source folder exists. If fso.FolderExists(strFolder) Then Set folSource = fso.GetFolder(strFolder) Else 'Folder does not exist, request it again. MsgBox &quot;Folder does not exist&quot; GoTo DoItAgain End If   strFolder = &quot;&quot; 'Get destination folder from user. DoItAgain2: strFolder = GetFolderFromUser(&quot;Destination&quot;) 'Verify that destination folder exists. If fso.FolderExists(strFolder) Then Set folDest = fso.GetFolder(strFolder) Else 'Folder does not exist, request folder again. MsgBox &quot;Folder does not exist&quot; 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)) = &quot;ppt&quot; Then ' If it is a PowerPoint presentation, open it. Set pres = PowerPoint.Presentations.Open(FileName:=folSource & &quot;\&quot; & fil.Name, _                           ReadOnly:=True) ' Then save it in the destination folder as HTML. pres.SaveAs folDest.Path & &quot;\&quot; & 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, &quot;Error #: &quot; & Err.Number End Sub

'Function to get folder locations and insert final &quot;\&quot; 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(&quot;What is the &quot; & strFolderType & &quot; folder?&quot;) 'Make sure that user typed something. If strFolder = &quot;&quot; Then End 'Make sure the final backslash is on the string. If Right(strFolder, 1) <> &quot;\&quot; Then strFolder = strFolder & &quot;\&quot; End If   GetFolderFromUser = strFolder End Function

