Article ID: 161135
Article Last Modified on 1/19/2007
Sub OrgMain()
' Variables.
Dim ShapeType, WhatIsSelected, CurrentView As Integer
Dim SlideCount, ObjectCount, SelectCount, i, x As Long
Dim Total, NextAvailable, top, BoxCount, LastSlide As Long
Dim WordRunning As Boolean
Dim word As Object
Dim StringTable(), OleObjectType, temp As String
' Keeps track of the number of text boxes in the chart.
Total = 0
BoxCount = 0
' Used for error trapping.
On Error Resume Next
Err.Clear
' Check the type of the item selected.
WhatIsSelected = ActiveWindow.Selection.Type
' Check to see whether any objects are selected.
If WhatIsSelected = ppSelectionNone Then
' No objects are selected, so end the macro.
MsgBox "No Organization Chart selected. " _
& "Please select an Organization Chart and run " _
& "the macro again.", vbInformation
End
End If
' Check to see whether a slide is selected.
If WhatIsSelected = ppSelectionSlides Then
' A slide is selected, so end the macro.
MsgBox "A slide is selected. " _
& "Please select an Organization Chart and run " _
& "the macro again.", vbInformation
End
End If
' Count the selections.
SelectCount = ActiveWindow.Selection.ShapeRange.Count
' If multiple objects selected, end the macro.
If SelectCount > 1 Then
MsgBox "Too many objects selected. " _
& "Please select 1 Organization Chart and run " _
& "the macro again.", vbInformation
End
End If
' If the selection is not a shape, exit the macro.
If WhatIsSelected <> ppSelectionShapes Then
MsgBox "The object selected is not " _
& "an Organization Chart. " _
& "Please select an Organization Chart and run " _
& "the macro again.", vbInformation, _
"Shape Check"
End
End If
' A shape is selected, so figure out what type of shape.
ShapeType = ActiveWindow.Selection.ShapeRange.Type
' Check to see whether the shape is an embedded OLE object.
' If not, exit the macro.
If ShapeType <> msoEmbeddedOLEObject Then
MsgBox "The object selected is not " _
& "an Organization Chart. " _
& "Please select an Organization Chart and run " _
& "the macro again.", vbInformation, _
"OLE Object Check"
End
End If
' Determine type of OLE object.
OleObjectType = ActiveWindow.Selection.ShapeRange.OLEFormat.ProgID
' See whether the object selected is an organization chart.
If OleObjectType <> "OrgPlusWOPX.4" And _
OleObjectType <> "MSOrgchart.2" Then
' If not an organization, exit the macro.
MsgBox "The object selected is not " _
& "an Organization Chart. " _
& "Please select an Organization Chart and run " _
& "the macro again.", vbInformation, _
"OLE Object Class Check"
End
End If
' Copy the Organization chart.
ActiveWindow.Selection.ShapeRange.Copy
' Count the number of slides.
SlideCount = ActivePresentation.Slides.Count
' Add a new slide to the end of the presentation.
ActivePresentation.Slides.Add (SlideCount + 1), ppLayoutBlank
' Save the current view.
CurrentView = ActiveWindow.ViewType
' Switch to slide view if not there already.
If CurrentView <> ppViewSlide Then
ActiveWindow.ViewType = ppViewSlide
End If
' Switch to the proper slide.
LastSlide = ActivePresentation.Slides.Count
ActiveWindow.View.GotoSlide Index:=LastSlide
' Paste the Organization chart to the temp slide.
ActiveWindow.View.Paste
' Ungroup the Organization chart.
ActiveWindow.Selection.ShapeRange.Ungroup.Select
ActiveWindow.Selection.Unselect
' Count the Organization chart objects.
With ActivePresentation.Slides(LastSlide).Shapes
ObjectCount = .Count
' Check all of the objects for text.
For x = ObjectCount To 1 Step -1
' See whether object has a text frame.
If .Item(x).HasTextFrame Then
' See whether object has text.
If .Item(x).TextFrame.HasText Then
' Increase the size of the array
' and save the contents.
ReDim Preserve StringTable(Total)
StringTable(Total) = .Item(x).TextFrame.TextRange.Text
Total = Total + 1
BoxCount = BoxCount + 1
Else
' See whether object has a fill.
If .Item(x).Fill.Visible = msoTrue Then
NextAvailable = Total - BoxCount
If BoxCount = 2 Or BoxCount = 3 Then
' Swap first and third Total.
temp = StringTable(NextAvailable)
StringTable(NextAvailable) = StringTable(Total - 1)
StringTable(Total - 1) = temp
End If
If BoxCount > 3 Then
top = 0
For i = BoxCount To 0 Step -1
' Set temp = to last item in array.
temp = StringTable(top)
StringTable(top) = StringTable(i)
StringTable(i) = temp
top = top + 1
If top = i Then
Exit For
End If
Next i
End If
' Add an extra Total to the end of the list.
ReDim Preserve StringTable(Total)
StringTable(Total) = ""
Total = Total + 1
BoxCount = 0
End If
End If
End If
Next x
' Checks to see if Word is running.
Set word = GetObject(, "Word.Application.8")
If Err.Number <> 0 Then
WordRunning = False
Else
WordRunning = True
End If
' Reset the error variable.
Err.Clear
' Create a Word object.
If WordRunning = False Then
Set word = CreateObject("Word.Application.8")
End If
If Err.Number <> 0 Then
MsgBox "Unable to launch Word. " _
& "This Macro requires Microsoft Word 97. " _
& "Make sure Word is running correctly and " _
& "then attempt to run the macro again. " _
, vbCritical _
, "Failed to launch Word"
End
End If
' Creates a new Word document based on normal.
word.Documents.Add
' Copy all the organization chart text to Word.
For x = 0 To Total
word.Selection.TypeText Text:=StringTable(x)
word.Selection.TypeParagraph
Next x
End With
' Delete the temp slide.
ActiveWindow.Selection.SlideRange.Delete
' Restore the current view.
If ActiveWindow.ViewType <> CurrentView Then
ActiveWindow.ViewType = CurrentView
End If
' Make Word visible if not.
If WordRunning = False Then
word.Application.Visible = True
End If
' A message indicating the macro is finished running.
MsgBox "Organization Chart text extracted " _
& "to a Word document"
End Sub
176476 OFF: Office Assistant Not Answering Visual Basic Questions
163435 VBA: Programming Resources for Visual Basic for Applications
Additional query words: 97 8.00 kbmacro ppt8 vba vbe
Keywords: kbcode kbdtacode kbhowto kbmacro kbprogramming KB161135