マーカーの追加
それでは，
作成するアドインでは，
現在のスライドへ四角形のオートシェイプの追加は次のように記述できます。追加する位置と大きさは決め打ちにしています。
Dim w = Application.ActiveWindow
Dim slide = DirectCast(w.View.Slide, PowerPoint.Slide)
Dim shape = w.Presentation.Slides(slide.SlideIndex).Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, 0, 0, 100, 100)
アドイン側で，
Private Const TagName As String = "SampleAddInObject"
Sub AddMarker()
Try
Dim w = Application.ActiveWindow
Dim slide = DirectCast(w.View.Slide, PowerPoint.Slide)
' 既にあるマーカーを削除
For i = slide.Shapes.Count To 1 Step -1
Dim s = slide.Shapes(i)
If s.Tags.Item(TagName) = "Marker" Then
s.Delete()
End If
Next
Dim shape = w.Presentation.Slides(slide.SlideIndex).Shapes.AddShape(Microsoft.Office.Core.MsoAutoShapeType.msoShapeRectangle, 0, 0, 100, 100)
shape.Tags.Add(TagName, "Marker")
Catch ex As Exception
' (例外は無視)
End Try
End Sub
マーカーの追加ボタンがクリックされたとき，
ここまでを実行してみましょう
図2 マーカーの追加
スライドショー時の処理
次は，
作成するアドインでは，
現在表示されているスライドの次のスライドにマーカーがあるかを確認し，
写真のダウンロードと表示は，
Private Sub Application_SlideShowNextSlide(Wn As Microsoft.Office.Interop.PowerPoint.SlideShowWindow) Handles Application.SlideShowNextSlide
If Wn.View.Slide.SlideIndex >= Wn.Presentation.Slides.Count Then
Exit Sub
End If
' 次のスライド
Dim slide = Wn.Presentation.Slides(Wn.View.Slide.SlideIndex + 1)
' スライドにマーカーがあるかチェック
Dim shape As PowerPoint.Shape = Nothing
For Each s As PowerPoint.Shape In slide.Shapes
If s.Tags.Item(TagName) = "Marker" Then
shape = s
Exit For
End If
Next
If shape Is Nothing Then
Exit Sub
End If
' マーカーがある場合，AddPicture メソッドをスレッドで処理する
Dim t = New Threading.Thread(AddressOf AddPicture)
t.SetApartmentState(Threading.ApartmentState.STA)
t.Start(New Tuple(Of PowerPoint.Slide, PowerPoint.Shape)(slide, shape))
End Sub
ただし，
Private Sub Application_SlideShowNextSlide(Wn As Microsoft.Office.Interop.PowerPoint.SlideShowWindow) Handles Application.SlideShowNextSlide
If Wn.View.Slide.SlideIndex >= Wn.Presentation.Slides.Count Then
Exit Sub
End If
' 次のスライド
Dim slide = Wn.Presentation.Slides(Wn.View.Slide.SlideIndex + 1)
' 以前にアドインで追加された写真を削除
For i = slide.Shapes.Count To 1 Step -1
Dim s = slide.Shapes(i)
If s.Tags.Item(TagName) = "InsertedPicture" Then
s.Delete()
End If
Next
If Me.LiveConnectClient Is Nothing Then
Exit Sub
End If
' スライドにマーカーがあるかチェック
Dim shape As PowerPoint.Shape = Nothing
For Each s As PowerPoint.Shape In slide.Shapes
If s.Tags.Item(TagName) = "Marker" Then
shape = s
Exit For
End If
Next
If shape Is Nothing Then
Exit Sub
End If
' マーカーがある場合，AddPicture メソッドをスレッドで処理する
Dim t = New Threading.Thread(AddressOf AddPicture)
t.SetApartmentState(Threading.ApartmentState.STA)
t.Start(New Tuple(Of PowerPoint.Slide, PowerPoint.Shape)(slide, shape))
End Sub
今回のアドインでは，