Microsoft Corporation
June 27, 1998
Introduction
Exporting a Microsoft Access Table into an Outlook Contacts Folder
Creating Mailing Labels from an Outlook Contact List Using Word
Creating a Presentation from a Microsoft Excel Workbook
Personalizing a Presentation for a Contact List
Exporting Outlook Journal Entries to a Microsoft Access Table
Creating a Web Presentation from a Word Document Using PowerPoint
Inserting a URL List from a Microsoft Access Table into a Word Document
Inserting a Microsoft Excel Value into a Word Bookmark
Additional Resources
Click here to copy the Automation samples discussed in this article.
This paper provides sample code for several cross-application solutions. It gives examples of using Automation to manipulate Microsoft® Outlook®, Microsoft Word, Microsoft Access, Microsoft PowerPoint®, and Microsoft Excel. It shows how to use data across applications and ways to convert one kind of document into another. By building from these examples, you can develop solutions that seamlessly use the full functionality of the Microsoft Office 97 suite of products.
The sample code in this paper uses early binding of object variables. This makes for more efficient and readable code. Early binding involves declaring object variables as specific objects rather than as just objects. For example, you declare an object variable used to point to a Word document as Document rather than as Object.
To use early binding, your project must reference the object libraries that contain the information needed about the objects you want to use. For example, to use early binding with a variable pointing to a Word document, your project must have a reference to the Microsoft Word 8.0 Object Library. You add this reference by opening the project in the Visual Basic® Editor (or, in Microsoft Access, opening a module in Design view), clicking References on the Tools menu, and selecting the appropriate object library.
To try the solutions described in this paper, download samp.exe, which contains the necessary sample files.
This section shows you how to add a list of contacts, stored in a Microsoft Access table, to your Outlook Contacts folder. It uses a subroutine, ExportContactsTable, and a function, boolCheckName.
The subroutine, ExportContactsTable, creates a new Outlook ContactItem object for each record in the table. It takes a table name as its only argument. The table should have these fields: ContactName, Address, City, Region, PostalCode, Country, Phone, Fax, CompanyName, ContactTitle, and CustomerId.
In the sample table there is a field, CustomId, which does not correspond to any of Outlook's built-in fields. The subroutine creates a custom field for an Outlook ContactItem. This custom field will be available as a User-defined field in Outlook through the Field Chooser.
The function boolCheckName is called by ExportContactsTable to do minimal checking of each contact name. It insures that the name is not a zero-length string and that it does not already exist in the Outlook Contacts list. It returns True if the contact should be added to the Contact List.
The sample code for this section, as well as a sample table of contacts, is in AccSamp.mdb. The code is in the modContacts module. To run this solution, open the database and click Export Contacts on the Samples form.
Note Running the sample code adds thirteen contacts to your Outlook Contact List. However, each contact name added to your list is preceded with the word "test" for easy deletion.
Note To use this code in your own project, you must reference the Microsoft Outlook 8.0 Object Library.
'Use a global constant for the message box caption.
Const MESSAGE_CAPTION = "Exporting Contacts to Microsoft Access"
Public Sub ExportContactsTable(strTableName As String)
Dim oOutlook As New Outlook.Application
Dim colItems As Items
Dim tblContacts As Recordset
Dim upContactId As UserProperty
Dim strMessage as String
Const ERR_TABLE_NOT_FOUND = 3078
Const ERR_FIELD_NOT_FOUND = 3265
Const ERR_ATTACHED_TABLE_NOT_FOUND = 3024
Const ERR_INVALID_ATTACHED_TABLE_PATH = 3044
On Error GoTo ERR_ExportContactsTable
'Open the table.
Set tblContacts = CurrentDb.OpenRecordset(strTableName)
'Get a reference to the Items collection of the contacts folder.
Set colItems = oOutlook.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderContacts).Items
Do Until tblContacts.EOF
If boolCheckName(Nz(tblContacts!ContactName), colItems) Then
'Use the Add method of Items collection to fill in the
'fields with the data from the table and then save the new
'item.
With colItems.Add
.FullName = Nz(tblContacts!ContactName)
.BusinessAddressStreet = Nz(tblContacts!Address)
.BusinessAddressCity = Nz(tblContacts!City)
.BusinessAddressState = Nz(tblContacts!Region)
.BusinessAddressPostalCode = Nz(tblContacts!PostalCode)
.BusinessAddressCountry = Nz(tblContacts!Country)
.BusinessTelephoneNumber = Nz(tblContacts!Phone)
.BusinessFaxNumber = Nz(tblContacts!Fax)
.CompanyName = Nz(tblContacts!CompanyName)
.JobTitle = Nz(tblContacts!ContactTitle)
'Create a custom field.
Set upContactId = .UserProperties. _
Add("ContactID", olText)
upContactId = Nz(tblContacts![CustomerID])
.Save
End With
End If
tblContacts.MoveNext
Loop
tblContacts.Close
strMessage = "Your contacts have been successfully exported."
MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION
Exit_ExportContactsTable:
On Error Resume Next
Set tblContacts = Nothing
Set oOutlook = Nothing
Exit Sub
ERR_ExportContactsTable:
Select Case Err
Case ERR_TABLE_NOT_FOUND
strMessage = "Cannot find table!"
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_ExportContactsTable
'These errors occur if an attached table is moved or deleted
'or if the path to the table file is no longer valid.
Case ERR_ATTACHED_TABLE_NOT_FOUND, ERR_INVALID_ATTACHED_TABLE_PATH
strMessage = "Cannot find attached table!"
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_ExportContactsTable
'If a field in the code does not match a field in the table,
'then move on to the next field.
Case ERR_FIELD_NOT_FOUND
Resume Next
Case Else
strMessage = "An unexpected error has occured. Error#" _
& Err & ": " & Error
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_ExportContactsTable
End Select
End Sub
Function boolCheckName(strName As String, colItems As Items) _
As Boolean
Dim varSearchItem As Variant
Dim strMessage As String
If Len(strName) = 0 Then
strMessage = "This record is missing a full name. "
strMessage = strMessage & "Do you want to add it anyway?"
If MsgBox(strMessage, vbYesNo, MESSAGE_CAPTION) = vbYes Then
boolCheckName = True
Else
boolCheckName = False
End If
Else
'Find the first item that has a FullName equal to strName. If no
'item is found, varSearchItem wil be equal to Nothing.
Set varSearchItem = colItems.Find("[FullName] = """ & strName & """")
If varSearchItem Is Nothing Then
boolCheckName = True
Else
strMessage = "A contact named " & strName & " already exists. "
strMessage = strMessage & _
"Do you want to add this contact anyway?"
If MsgBox(strMessage, vbYesNo, MESSAGE_CAPTION) = vbYes Then
boolCheckName = True
Else
boolCheckName = False
End If
End If
End If
End Function
This section shows you how to create mailing labels from an Outlook Contact list using the MailMerge object in Word. Word recognizes a wide variety of mailing labels. These label types are identified by string names. You can get a list of the label types available by clicking Envelopes and Labels on the Tools menu, clicking the Labels tab, clicking Options, then examining the Product number list box.
The CreateContactsLabels procedure, shown below, creates the mailing labels. It first inserts text and placeholder strings into a document. It calls the subroutine FormatRange to prepare a Range object with the fields needed for the mailing labels. FormatRange is sent a MailMergeFields collection object. It finds and replaces each placeholder string, phField, with the appropriate mail merge field. Using placeholders guarantees that the MailMerge fields are inserted exactly where you want them.
The CreateContactLabels procedure then stores the range as an AutoText entry. It uses the CreateNewDocument method of the MailingLabel object to create the mailing labels based on the AutoText entry.
The CreateContactLabels procedure also shows how the DataSource object can be used to filter or sort records. This object's QueryString property is filled with an SQL string before the MailMerge object is executed.
When you call the CreateContactLabels procedure, you need to supply a string that names the specific label type. For example, to create Avery 5160 labels, use the following code:
CreateContactsLabels "5160"
The sample code for this section is in the template WrdSamp.dot. To run the sample code, copy WrdSamp.dot to your Office Templates directory, create a new document based on the WrdSamp.dot template, and click Quick Labels on the Tools menu. Choose a label from the drop-down list box, and then click Create Labels.
Note Because CreateContactsLabels works with the MailMerge object, it can create mailing labels from the Outlook Contacts folder without a reference to the Outlook object library.
Public Sub CreateContactsLabels(strLabelName As String)
Dim docMergeDoc As Document
Dim rngRange As Range
Dim strSQL As String
Dim intCurrentField As Integer
Dim strMessage As String
Const MESSAGE_CAPTION = "Creating Mailing Labels for Contacts"
Const LABEL_NOT_FOUND = 5843
On Error GoTo Err_CreateContactsLabels
'Add a new document and set a reference to it.
Set docMergeDoc = Documents.Add
With docMergeDoc.MailMerge
'Set values for mailing labels mail merge based on
'Outlook Address Book (olk).
.MainDocumentType = wdMailingLabels
.UseAddressBook Type:="olk"
'Prepare a range with string placeholders (phField) for MailMerge
'fields.
Set rngRange = docMergeDoc.Range
With rngRange
.InsertAfter "phField phField"
.InsertParagraphAfter
.InsertAfter "phField"
.InsertParagraphAfter
.InsertAfter "phField, phField phField"
End With
'Add the MailMerge fields calling FormatRange.
FormatRange .Fields
'Copy the range to an AutoTextEntry.
NormalTemplate.AutoTextEntries.Add "LabelText", rngRange
'Create a mailing label template using AutoTextEntry.
Application.MailingLabel.CreateNewDocument Name:=strLabelName, _
Address:="", AutoText:="LabelText"
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
strSQL = "SELECT * FROM " & .Name
strSQL = strSQL & " ORDER BY Last_Name"
.QueryString = strSQL
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute
'Close docMergeDoc without saving changes.
docMergeDoc.Close SaveChanges:=wdDoNotSaveChanges
End With
'The AutoTextEntry is no longer needed so delete it.
NormalTemplate.AutoTextEntries("LabelText").Delete
'Activate and save the labels. Microsoft Word adds the new
'document to the beginning of the Documents collection.
Documents(1).Activate
With Dialogs(wdDialogFileSaveAs)
.Name = "ContactLabels.doc"
.Show
End With
Exit_CreateContactsLabels:
On Error Resume Next
Set rngRange = Nothing
Set docMergeDoc = Nothing
Exit Sub
Err_CreateContactsLabels:
If Err = LABEL_NOT_FOUND Then
strMessage = "'" & strLabelName & "' is not a recognized label name!"
Else
strMessage = "An unexpected error, #" & Err & " : " & Error _
& " has occured."
End If
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_CreateContactsLabels
End Sub
The FormatRange procedure is called by CreateContactLabels to replace the string placeholders with mail merge fields.
Private Sub FormatRange(mgfFields As MailMergeFields)
Dim strFieldName As String
Dim intCurrentField As Integer
Dim rngRange As Range
Dim docMergeDoc As Document
Set docMergeDoc = mgfFields.Parent.Parent
For intCurrentField = 0 To 5
Set rngRange = docMergeDoc.Range
'Look for phField.
With rngRange.Find
.MatchWholeWord = True
.Execute FindText:="phField"
'If phField is found, use intCurrentField to determine which
'field to insert, then add the field.
If .Found Then
Select Case intCurrentField
Case 0
strFieldName = "First_Name"
Case 1
strFieldName = "Last_Name"
Case 2
strFieldName = "Street_Address"
Case 3
strFieldName = "City"
Case 4
strFieldName = "State_or_Province"
Case 5
strFieldName = "Postal_Code"
End Select
mgfFields.Add Range:=rngRange, Name:=strFieldName
End If
End With
Next intCurrentField
Set rngRange = Nothing
Set docMergeDoc = Nothing
End Sub
This section shows how you can convert a Microsoft Excel workbook into a PowerPoint presentation. The following sample code creates a presentation that contains a title page and all the worksheets and charts in the workbook from which the code is run. The bulk of the code is found in the CreateXLPowerPointPresentation procedure. This procedure creates the PowerPoint presentation and applies a template.
Each worksheet or chart is added to a new slide in the following manner:
Note The Copy method of a Worksheet object creates a new workbook when called without arguments.
The CreateXLPowerPointPresentation procedure calls a function, strTemplateGet, to get the full name and path of a template. This template is then applied to the presentation. Examining the code in this function goes beyond the scope of this article, but the code is included in the sample files.
The code for this sample is found in the modPPTPresentation module in XLSamp.xls. To run it, open XLSamp.xls, then click Convert To Presentation on the Tools menu.
Note To use this code, you must reference the Microsoft PowerPoint 8.0 Object Library.
Public Sub CreateXLPowerPointPresentation()
Dim oPowerPoint As New PowerPoint.Application
Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim ws As Worksheet
Dim ch As Chart
Dim wkb As Workbook
Dim strTempWKB As String
Dim strMeadowTemplate As String
Dim strMessage As String
On Error GoTo Err_CreateXLPowerPointPresentation
Const MESSAGE_CAPTION = "Creating a PowerPoint Presentation"
'Build name of temporary Workbook.
With Application
strTempWKB = .Path & .PathSeparator & "TempWKB.xls"
End With
'Create a new Presentation and add a title slide.
Set pptPresentation = oPowerPoint.Presentations.Add
With pptPresentation.Slides
Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
pptSlide.Shapes.Title.TextFrame.TextRange.Text = "My Presentation"
'Place each worksheet in a slide.
For Each ws In ThisWorkbook.Worksheets
'Copy sheet to temporary Workbook. Copy creates a new workbook
'and makes it the active workbook.
ws.Copy
Set wkb = ActiveWorkbook
wkb.SaveAs strTempWKB
'The numbers used here are somewhat arbitrary.
Set pptSlide = .Add(.Count + 1, ppLayoutBlank)
pptSlide.Shapes.AddOLEObject Left:=120, Top:=110, _
Width:=480, Height:=320, _
FileName:=strTempWKB, _
Link:=msoFalse
'Close temporary Workbook and delete it.
wkb.Close SaveChanges:=msoFalse
Kill strTempWKB
Next ws
'Place each chart in a slide.
For Each ch In ThisWorkbook.Charts
'Copy chart to temporary Workbook.
ch.Copy
Set wkb = ActiveWorkbook
wkb.SaveAs strTempWKB
Set pptSlide = .Add(.Count + 1, ppLayoutBlank)
pptSlide.Shapes.AddOLEObject Left:=120, Top:=110, _
Width:=480, Height:=320, _
FileName:=strTempWKB, _
Link:=msoFalse
'Close temporary Workbook and delete it.
wkb.Close SaveChanges:=msoFalse
Kill strTempWKB
Next ch
End With
'Apply meadow template if successfully found.
strMeadowTemplate = strTemplateGet("Meadow")
If Len(Dir(strMeadowTemplate)) > 0 Then
pptPresentation.ApplyTemplate strMeadowTemplate
End If
oPowerPoint.Visible = msoTrue
Exit_CreateXLPowerPointPresentation:
On Error Resume Next
Set oPowerPoint = Nothing
Set pptPresentation = Nothing
Set pptSlide = Nothing
Exit Sub
Err_CreateXLPowerPointPresentation:
strMessage = "An unexpected error has occured. Error#" _
& Err & ": " & Error
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_CreateXLPowerPointPresentation
End Sub
This section illustrates how you can personalize a PowerPoint presentation for your Outlook contacts, which can be an effective sales tool. The sample code below iterates through your Outlook Contacts folder and copies a PowerPoint presentation with a customized title slide for each contact. It then either e-mails the personalized presentation to the contact or saves the message in your Inbox so you can add text and send it later. This code can be run from a Microsoft Excel, Word, or Access module.
The procedure, PersonalizePresentation, takes two arguments: strFileName, which is the name of a presentation, and boolSendNow, a flag that indicates whether to send the presentations immediately or save them in the Inbox. The procedure opens the presentation and points a variable, txrRange, to the text of the title on the first slide. Next, it iterates through the Contacts folder and adds each Contact's full name to txrRange and saves each modified presentation as contact name.ppt. If the contact has an e-mail address, the procedure creates a MailItem and saves the personalized presentation as an attachment in your Inbox or sends it, depending on the option selected.
The code for this sample is in the modPersonalize module in XLSamp.xls. To run it, open XLSamp.xls and click Personalize Presentation on the Tools menu. When prompted for a presentation, browse to Sample.ppt.
Note To use this code in your own Microsoft Excel project, you must reference both the both Microsoft PowerPoint 8.0 Object Library and the Microsoft Outlook 8.0 Object.
Note that txrRange is declared as PowerPoint.TextRange because the application running this code may also have a TextRange object.
Public Sub PersonalizePresentation(strFileName As String, _
boolSendNow As Boolean)
Dim oPowerPoint As New PowerPoint.Application
Dim oOutlook As New Outlook.Application
Dim pptPresentation As Presentation
Dim txrRange As PowerPoint.TextRange
Dim intCounter As Integer
Dim mitMailItem As MailItem
Dim strNewFile As String
Dim strEMailName As String
Dim strMessage As String
Dim strPath As String
Dim lngSendNow As Long
Const ERR_INVALID_PRESENTATION = 245755
Const MESSAGE_CAPTION = "Personalizing a PowerPoint Presentation"
On Error GoTo Err_PersonalizePresentation
'Check to see if the file exists.
If Len(Dir(strFileName, vbNormal)) > 0 Then
oPowerPoint.Visible = msoTrue
Set pptPresentation = oPowerPoint.Presentations.Open(strFileName)
strPath = pptPresentation.Path
Set txrRange = pptPresentation.Slides(1).Shapes(1) _
.TextFrame.TextRange
'Open the Contacts folder.
With oOutlook.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderContacts).Items
'Add Contact name to TextRange and save new Presentation.
For intCounter = 1 To .Count
txrRange.Text = .Item(intCounter).FullName _
& "'s Presentation"
strNewFile = strPath & _
Application.PathSeparator & _
.Item(intCounter).FullName & ".ppt"
pptPresentation.SaveAs strNewFile
'Send Presentation as Attachment if Contact has e-mail
'address.
strEMailName = .Item(intCounter).Email1Address
If Len(strEMailName) > 0 Then
Set mitMailItem = oOutlook.CreateItem(olMailItem)
With mitMailItem
.Attachments.Add strNewFile
.Recipients.Add strEMailName
.Subject = "Customized Presentation"
If boolSendNow Then
.Send
Else
.Save
End If
End With
End If
Next intCounter
End With
Else
strMessage = "File not found!"
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
End If
Exit_PersonalizePresentation:
On Error Resume Next
oPowerPoint.Quit
Set oPowerPoint = Nothing
Set pptPresentation = Nothing
Set txrRange = Nothing
Set oOutlook = Nothing
Exit Sub
Err_PersonalizePresentation:
If vbObjectError - Err = ERR_INVALID_PRESENTATION Then
strMessage = "PowerPoint cannot open this file!"
Else
strMessage = "An unexpected error, #" & Err & " : " & _
Error & " has occured."
End If
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_PersonalizePresentation
End Sub
This section shows how you can export information stored in an Outlook Journal folder into a Microsoft Access table. This can be useful if you are using the Journal folder in Outlook to keep a history of a project. You can store this information in Microsoft Access, where you can sort and view it in several ways.
The following code sample assumes that you have two tables, Projects and ProjectHistory, in a Microsoft Access database. The first table contains general information about a project and the second table contains details on the progress of a project. For the purposes of the code, the Project table has at least three fields: ProjectName, ProjectId, and LastUpdated. It also has an index called Subject on the ProjectName field. The ProjectName corresponds to the Subject field of an Outlook JournalItem. The ProjectHistory table requires the fields ProjectId (the foreign key), DetailDateTimeStamp, and DetailDuration.
The UpdateProjectHistory procedure is passed the name of a project. (Note that the name of a project must correspond to a subject in an Outlook JournalItem.) The procedure opens the Journal folder and retrieves only the items for that project, using the Restrict method of the JournalItems collection. The procedure then checks to see if the name passed to it is in the Projects table. If the project is new, the project name won't be found, so the procedure adds the project to the table.
Next, the procedure retrieves the date from the projects LastUpdated field and stores it in dteUpdated. If it does not find a date, the procedure assigns 1/1/95 to dteUpdated, which insures that all the JournalItems will be seen as new (assuming there are no JournalItems older than 1/1/95). Next, the procedure iterates through these items. If a JournalItem has a CreationTime greater than the project's LastUpdated date, then the information in this item is added as a new record in the ProjectHistory table.
AccSamp.mdb contains the sample code, as well as the two tables needed to run this solution. The code is found in the modProjectHistory module. To run the code, click Update Project in the Samples form. When prompted for project, use a name from the Subject field of your Journal.
Note To use this code from a Microsoft Access module, you must reference the Microsoft Outlook 8.0 Object Library.
Sub UpdateProjectHistory(strSubject As String)
Dim tblProjects As Recordset
Dim tblDetails As Recordset
Dim dbs As Database
Dim lngProjectId As Long
Dim oOutlook As New Outlook.Application
Dim colItems As Items
Dim intCtr As Integer
Dim dteUpdated As Date
Dim strMessage As String
Const MESSAGE_CAPTION = "Updating Project History"
On Error GoTo Err_UpdateProjectHistory
'Get all JournalItems for project.
Set colItems = oOutlook.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderJournal). _
Items.Restrict("[Subject] = '" & strSubject & "'")
'Check to see if there are any Journal items. If there
'are no Journal items, then display a message and
'exit.
If colItems.Count > 0 Then
Set dbs = CurrentDb
'Open tables and search for subject in Projects.
Set tblProjects = dbs.OpenRecordset("Projects")
Set tblDetails = dbs.OpenRecordset("ProjectHistory")
'Seek is used because it is fast. It has the disadvantage
'that it will not work on an attached table.
tblProjects.Index = "Subject"
tblProjects.Seek "=", strSubject
'If there is no match, add new record and set the
'recordset's Bookmark property to LastModified to move to
'that record.
With tblProjects
If .NoMatch Then
.AddNew
tblProjects!Subject = strSubject
.Update
.Bookmark = .LastModified
End If
End With
'Get the ProjectId from the current record.
lngProjectId = tblProjects!SubjectId
'If the LastUpdated field is null, assign dteUpdated an early
'date to use all records. Otherwise assign LastUpdated to
'dteUpdated.
If IsNull(tblProjects!LastUpdated) Then
dteUpdated = #1/1/95#
Else
dteUpdated = tblProjects!LastUpdated
End If
'Add details if there are any that are dated later than dteUpdated.
If colItems.Count > 0 Then
With tblDetails
For intCtr = 1 To colItems.Count
If CDate(colItems(intCtr).CreationTime) > dteUpdated Then
.AddNew
tblDetails!SubjectId = lngProjectId
tblDetails!DateTimeStamp = colItems(intCtr). _
CreationTime
tblDetails!Duration = colItems(intCtr).Duration
.Update
End If
Next intCtr
.Close
End With
'Update LastUpdated field.
With tblProjects
.Edit
tblProjects!LastUpdated = Now
.Update
.Close
End With
End If
strMessage = "Project successfully updated."
MsgBox strMessage, vbOKOnly, MESSAGE_CAPTION
Else
strMessage = "Project not found!"
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
End If
Exit_UpdateProjectHistory:
On Error Resume Next
Set oOutlook = Nothing
Set tblProjects = Nothing
Set tblDetails = Nothing
Set dbs = Nothing
Exit Sub
Err_UpdateProjectHistory:
strMessage = "An unexpected error, #" & Err & " : " & _
Error & " has occured."
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_UpdateProjectHistory
End Sub
This section shows how you can use features in PowerPoint to convert a Word document into a Web site. You first convert the Word document into a PowerPoint presentation. Then PowerPoint creates a Web site that functions like a PowerPoint presentation.
It's easy to convert a Word document to a presentation if you have organized the document with headings, but what if your Word document is divided into sections? The following code, run from Word, places each section on a slide and then converts the presentation to a Web site using the PowerPoint Web Wizard. The procedure, ConvertToPPTWeb, uses the Save as HTML command (File menu) to launch the PowerPoint Web Wizard.
The ConvertToPPTWeb procedure calls a function, strTemplateGet, to get the full name and path of a template. This template is then applied to the presentation. Examining the code in this function goes beyond the scope of this article, but the code is included in the sample files.
The sample code is found in WrdSamp.dot and Sections.doc is a Word document that has been divided into sections. To run the sample code, copy WrdSamp.dot to your Office Templates directory, create a new document based on the WrdSamp.dot template, and click Convert to PPT Web on the Tools menu. Browse to Sections.doc and click Open.
The HTML files created by the wizard are saved in a subfolder named Presentationx under the location you specified. To see the Web presentation, look in this folder and open Index.htm with your browser.
Note To run this example in your own project, you must reference the Microsoft PowerPoint 8.0 Object Library.
Public Sub ConvertToPPTWeb(strName As String)
Dim docWebBase As Document
Dim secSection As Section
Dim rngRange As Range
Dim docTemp As Document
Dim oPowerpoint As New PowerPoint.Application
Dim pptPresentation As Presentation
Dim pptSlide As Slide
Dim strTempDoc As String
Dim strMessage As String
Dim rngHeading As Range
Dim strHeading As String
Dim strTemplate As String
Const MESSAGE_CAPTION = "Converting Word Document to Web Presentation"
Const FILE_MENU = 1
Const SAVE_AS_HTML = 6
'On Error GoTo Err_ConvertToPPTWeb
With Application
strTempDoc = .Path & .PathSeparator & "TempDoc.doc"
End With
'Open the Word document.
Set docWebBase = Documents.Open(strName)
With oPowerpoint
Set pptPresentation = .Presentations.Add
'Iterate through sections.
With pptPresentation.Slides
For Each secSection In docWebBase.Sections
Set rngRange = secSection.Range
rngRange.Copy
'Create a temporary document for each section.
Set docTemp = Documents.Add
Set rngRange = docTemp.Range
rngRange.Paste
'Go to the first heading.
Set rngHeading = docTemp.GoTo(What:=wdGoToHeading, _
Which:=wdGoToFirst)
'Expand the range to include the whole heading.
rngHeading.Expand wdParagraph
'Make sure heading is Heading 1. If it is not,
'create a heading.
If rngHeading.Style = "Heading 1" Then
strHeading = rngHeading.Text
rngHeading.Delete
Else
strHeading = "Slide " & (.Count + 1)
End If
docTemp.SaveAs strTempDoc
Set pptSlide = .Add(.Count + 1, ppLayoutTitleOnly)
'Fill title with the heading.
pptSlide.Shapes(1).TextFrame.TextRange = strHeading
'The numbers here are arbitrary and should be based
'on the dimensions of the document sections.
pptSlide.Shapes.AddOLEObject Left:=30, Top:=80, _
Width:=640, Height:=420, _
FileName:=strTempDoc, _
Link:=msoFalse
'Close and delete temporary file.
docTemp.Close wdDoNotSaveChanges
Kill strTempDoc
Next secSection
End With
'Apply Contemporary template if successfully found.
strTemplate = strTemplateGet("Contemporary")
If Len(Dir(strTemplate)) > 0 Then
pptPresentation.ApplyTemplate strTemplate
End If
docWebBase.Close
.Visible = msoTrue
'Execute File, Save as HTML.
.CommandBars("Menu Bar").Controls(FILE_MENU). _
Controls(SAVE_AS_HTML).Execute
End With
Exit_ConvertToPPTWeb:
On Error Resume Next
Set docWebBase = Nothing
Set secSection = Nothing
Set rngRange = Nothing
Set docTemp = Nothing
Set rngHeading = Nothing
Set oPowerpoint = Nothing
Set pptPresentation = Nothing
Set pptSlide = Nothing
Exit Sub
Err_ConvertToPPTWeb:
If Err = 5174 Or Err = 5273 Then
strMessage = "Unable to locate file!"
Else
strMessage = "An unexpected error, #" & Err & " : " & _
Error & " has occured."
End If
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_ConvertToPPTWeb
End Sub
This section offers an example of inserting a URL list, stored in Microsoft Access, into a Word document. Managing URLs can be difficult. If you have stored URLs in a Microsoft Access table in such a way that they can be easily grouped, you may want to be able to fetch one of these groups and insert them into your Word document.
The following sample procedure, InsertURLs, inserts URLs into a range. It takes three arguments: the full name of a database, the category of URLs to be fetched, and a Range object. It is assumed that the database contains a table named URL with a URL field and a Category field. The URL field stores its data using the Microsoft Access Hyperlink data type. Microsoft Access stores a hyperlink as text followed by an address enclosed in pound signs. For example, www.microsoft.com is stored as
www.microsoft.com#http://www.microsoft.com#.
The InsertURLs procedure parses this string obtaining the anchor text and the address. It then adds the hyperlink to the range's Hyperlink collection. You can insert the hyperlinks at the current selection by setting a Range variable to Selection and calling InsertURLs with the proper arguments.
The following sample can be run from a Word module. The code is in WrdSamp.dot and the table of URLs is in AccSamp.mdb. To run the sample code, copy WrdSamp.dot to your Office Templates directory, create a new document based on the WrdSamp.dot template, and click Insert URLs on the Tools menu. Browse to AccSamp.mdb and enter Office 97 in the Category text box, then click OK.
Note To run this example, you must reference the Microsoft DAO 3.5 Object Library.
Public Sub InsertURLs(strDatabase As String, strCategory As String, _
rngRange As Word.Range)
Dim dbs As Database
Dim dynURLs As Recordset
Dim strSQL As String
Dim varURLs As Variant
Dim strAddress As String
Dim strAnchor As String
Dim strMessage As String
Const MESSAGE_CAPTION = "Inserting URLs in a Word Document"
On Error GoTo Err_InsertURLs
'Fetch hyperlinks.
Set dbs = DBEngine.Workspaces(0).OpenDatabase(strDatabase)
'Build SQL.
strSQL = "SELECT URL FROM URLs "
strSQL = strSQL & "WHERE Category=""" & strCategory & """;"
Set dynURLs = dbs.OpenRecordset(strSQL, dbOpenDynaset)
'Iterate through and parse URLs.
Do Until dynURLs.EOF
varURLs = dynURLs!URL
strAddress = Mid(varURLs, InStr(1, varURLs, "#") + 1, _
Len(varURLs) - 1)
strAnchor = Left(varURLs, InStr(1, varURLs, "#") - 1)
'Add URL to range.
With rngRange
.InsertAfter strAnchor
.Hyperlinks.Add Anchor:=rngRange, Address:=strAddress
.Collapse wdCollapseEnd
.InsertParagraph
.Collapse wdCollapseEnd
dynURLs.MoveNext
End With
Loop
dynURLs.Close
dbs.Close
Exit_InsertURLs:
On Error Resume Next
Set dynURLs = Nothing
Set dbs = Nothing
Exit Sub
Err_InsertURLs:
strMessage = "An unexpected error, #" & Err & " : " & _
Error & " has occured."
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_InsertURLs
End Sub
This section shows how you can read values from a Microsoft Excel worksheet and insert them as Word bookmarks. The following sample procedure, FillBookmarks, iterates through the Cells in a Range and inserts their values into bookmarks in a Word document. The FillBookmarks procedure opens a Word document and then iterates through the cells in the range passed to it. It increments the bookmark index, lCurrentIndex, and, as long as it does not run out of bookmarks, it inserts the value of the cell at the bookmark.
The code for this sample is found in the modBookmarks module in XLSamp.xls. To run it, open XLSamp.xls, then click Insert Range into Bookmarks on the Tools menu. When prompted for a document, browse to BkMks.doc.
Note To run this example, you must reference the Microsoft Word 8.0 Object Library.
Public Sub FillBookMarks(rngRange As Excel.Range, strFileName As String)
Dim docDocument As Document
Dim celCell As Variant
Dim oWord As New Word.Application
Dim lCurrentIndex As Long
Dim strInsert
Dim strMessage As String
Const MESSAGE_CAPTION = "Inserting Bookmarks"
On Error GoTo Err_FillBookMarks
'Initialize index.
lCurrentIndex = 1
'Open Document.
With oWord
Set docDocument = .Documents.Open(FileName:=strFileName)
'Show changes.
.Visible = True
.Activate
.WindowState = wdWindowStateMaximize
End With
'Iterate through Range cells adding values to Bookmarks.
With docDocument.Bookmarks
For Each celCell In rngRange.Cells
'Make sure you have not run out of Bookmarks.
If lCurrentIndex <= .Count Then
strInsert = celCell.Value
.Item(lCurrentIndex).Range.InsertAfter strInsert
End If
lCurrentIndex = lCurrentIndex + 1
Next celCell
End With
Exit_FillBookMarks:
On Error Resume Next
Set docDocument = Nothing
Set oWord = Nothing
Exit Sub
Err_FillBookMarks:
strMessage = "An unexpected error, #" & Err & " : " & _
Error & " has occured."
MsgBox strMessage, vbCritical, MESSAGE_CAPTION
Resume Exit_FillBookMarks
End Sub
To learn more about cross-application automation, see the Microsoft Office 97/Visual Basic Programmer's Guide (Microsoft Press), or the online version at http://msdn.microsoft.com/library/officedev/office/web/toc/fulltoc.htm, and the VBA Developer's Handbook by Ken Getz and Mike Gilbert (Sybex Inc., 1997).