Streve,
I believe that, at least until I find the need, I can declare victory
with the following code.
Sub TestShapes()
Dim numShapes, numAutoShapes, i As Long
Dim oSld As Slide
Dim oTxtRange As TextRange
Dim varTextFrame As Variant
On Error GoTo HandleError
Stop
StartAgain:
Set myDocument =
ActivePresentation.Slides(ActivePresentation.Slides.Count)
With myDocument.Shapes
numShapes = .Count
If numShapes > 1 Then
numTextShapes = 0
For i = 1 To numShapes - 1
If .Item(i).HasTextFrame Then
' If .Item(i).HasText Then
numTextShapes = numTextShapes + 1
varTextFrame = .Item(i).Name
ActiveWindow.View.GotoSlide
Index:=ActivePresentation.Slides.Count
Set oSld =
ActivePresentation.Slides(ActivePresentation.Slides.Count)
ActiveWindow.Selection.SlideRange.Shapes(varTextFrame).Select
Set oTxtRange =
oSld.Shapes(varTextFrame).TextFrame.TextRange
If Mid$(oTxtRange.Sentences(1), 1, Len("America"))
=
"America" Then
With oTxtRange.Sentences(1) _
.ActionSettings(ppMouseClick).Hyperlink
.Address = "
http://www.gsms-am.eds.com/
<
http://www.gsms-am.eds.com/> "
.TextToDisplay = "Americas:
http://www.gsms-am.eds.com <
http://www.gsms-am.eds.com> " & vbNewLine
.SubAddress = ""
End With
With oTxtRange.Sentences(2) _
.ActionSettings(ppMouseClick).Hyperlink
.Address = "
http://www.gsms-ap.eds.com/
<
http://www.gsms-ap.eds.com/> "
.TextToDisplay = "Asia Pacific:
http://www.gsms-ap.eds.com <
http://www.gsms-ap.eds.com> " & vbNewLine
.SubAddress = ""
End With
With oTxtRange.Sentences(3) _
.ActionSettings(ppMouseClick).Hyperlink
.Address = "
http://www.gsms-ea.eds.com/
<
http://www.gsms-ea.eds.com/> "
.TextToDisplay = "Europe & Africa:
http://www.gsms-ea.eds.com <
http://www.gsms-ea.eds.com> "
.SubAddress = ""
End With
End If
' Else
' DeletEmptyShapes
' End If
End If
NextFor:
Next
End If
End With
Exit Sub
HandleError:
'Stop
If Err.Number = 9 Then
GoTo NextFor
End If
' Resume
'If Err.Number <> 0 Then
' Msg = "Error # " & Str(Err.Number) & " was generated by " _
' & Err.Source & Chr(13) & Err.Description
' MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
'End If
CopyLastSlide
GoTo StartAgain
End Sub
Sub CopyLastSlide()
'
' Macro created 1/18/2005 by Jeff Jones
'
Windows.Item(Index:=2).Activate
ActiveWindow.ViewType = ppViewSlideSorter
ActiveWindow.Selection.Copy
ActiveWindow.ViewType = ppViewNormal
Windows.Item(Index:=2).Activate
ActiveWindow.View.Paste
ActiveWindow.ViewType = ppViewSlideSorter
ActivePresentation.Slides.Range(Array((ActivePresentation.Slides.Count
-
1))).Select
ActiveWindow.Selection.SlideRange.Delete
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Count
End Sub
I tried commenting out the SlideGoTo and the TextFrame selection but
ended up with errors I couldn't trap so I left them in. Oh well. I
tested against 33 of the 150+ presentations with no problems. I
suspect that I'll find other opportunities but for the most part, the
entire effort will be automated and therefore much preferable over
manually making the changes.
Thank you!
Take care,
Jeff
)