前回の記事でPowerPoint 2013でYouTubeの動画が挿入できない問題と、その問題を解決するためのマクロを紹介しましたが、マクロに慣れていない方にとっては作業が難しい面もありますので、PowerPointでYouTubeの動画を挿入するためのアドイン(フリーソフト)を作成しました(PowerPoint 2010/2013 に対応)。

・ファイルのダウンロード

ファイルはZip形式で圧縮していますので、Lhaplus等の圧縮解凍ソフトで解凍してからお使いください。

※ 当アドインの設定方法については付属の「readme.pdf」ファイルをご参照ください。

■ 使い方

PowerPointで当アドインを設定すると「挿入」タブに「YouTube 挿入」ボタンが追加されます。

このボタンをクリックすると「ビデオID入力」ボックスが表示されるので、YouTube動画のIDを入力して「OK」ボタンをクリックします。

※ ビデオIDは動画のURL[http://www.youtube.com/watch?v=***]の[***]部分にあたります。

動画の確認メッセージが表示されるので、問題が無ければ「はい」ボタンをクリックします。

「動画を現在のスライドに挿入しました。」とのメッセージが表示され、選択中のスライドに動画が挿入されれば作業終了です。スライドショーを実行して動画の再生を確認してください。

※ 動画の挿入には時間が掛かる場合があります。

今後YouTubeやPowerPointの仕様変更に伴って、アドインが動作しなくなる可能性はありますが、2013/9/5 現時点ではとりあえず動作しますので、興味がある方は是非ご利用ください。

また、当アドインのVBAコードとリボンXMLは下記になりますので、当ツールをカスタマイズしたい方は下記コードをご利用ください。

・VBAコード

'YouTube動画をアクティブなスライドに挿入するPowerPointマクロ
'PowerPoint 2010/2013対応
'@kinuasa

Option Explicit

Public Sub btnYouTubeInsert_onAction(control As IRibbonControl)
  Call InsertYouTubeVideoExec
End Sub

Private Sub InsertYouTubeVideoExec()
  Dim VideoID As String
  Dim title As String
  
  title = "" '初期化
  VideoID = VBA.InputBox("YouTube動画のビデオIDを入力してください。" & vbCrLf & vbCrLf & _
                  "※ ビデオID:動画のURL[http://www.youtube.com/watch?v=***]の[***]部分", "ビデオID入力")
  If StrPtr(VideoID) = 0 Or Len(Trim(VideoID)) < 1 Then Exit Sub
  title = GetYouTubeVideoTitle(VideoID)
  If Len(Trim(title)) < 1 Then Exit Sub
  If MsgBox("挿入しようとしている動画は" & vbCrLf & vbCrLf & title & vbCrLf & vbCrLf & "で良いですか？", vbYesNoCancel + vbQuestion + vbSystemModal) = vbYes Then
    InsertYouTubeVideo VideoID
    MsgBox "動画を現在のスライドに挿入しました。", vbInformation + vbSystemModal
  End If
End Sub

Private Sub InsertYouTubeVideo(ByVal VideoID As String)
'ビデオIDを指定してYouTube動画をアクティブなスライドに挿入する
  Dim sld As PowerPoint.Slide
  Dim embed As String
  
  Set sld = Nothing '初期化
  Set sld = GetActiveSlide(ActivePresentation)
  If Not sld Is Nothing Then
    embed = "<object><param name=""movie"" value=""http://www.youtube.com/v/" & VideoID & "&amp;version=2"" /></object>"
    sld.Shapes.AddMediaObjectFromEmbedTag embed
  End If
End Sub

Private Function GetYouTubeVideoTitle(ByVal VideoID As String) As String
'YouTube動画のタイトルを取得
  Dim url As String
  Dim ret As String
  Dim s As String
  Dim n As Object
  
  ret = "": s = "": Set n = Nothing '初期化
  url = "http://gdata.youtube.com/feeds/api/videos/" & VideoID
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send
    If .Status = 200 Then s = .responseText 'responseXMLだと上手くいかなかったのでresponseText使用
  End With
  If Len(Trim(s)) > 0 Then
    With CreateObject("MSXML2.DOMDocument")
      .async = False
      If .LoadXML(s) Then
        Set n = .SelectSingleNode("/entry/title")
        If Not n Is Nothing Then
          ret = n.Text 'title要素の内容取得
        End If
      End If
    End With
  End If
  On Error GoTo 0
  GetYouTubeVideoTitle = ret
End Function

Private Function GetActiveSlide(ByVal p As Presentation) As Slide
'アクティブなスライドを取得
  Dim ret As Slide
  
  Set ret = Nothing '初期化
  On Error Resume Next
  Set ret = p.Slides.FindBySlideID(p.Windows(1).Selection.SlideRange.SlideID)
  On Error GoTo 0
  Set GetActiveSlide = ret
End Function

・リボンXML

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <ribbon>
    <tabs>
      <tab idMso="TabInsert">
        <group id="grpYouTubeInsert" label="YouTube 挿入" insertAfterMso="GroupInsertMediaClips" screentip="YouTubeの動画挿入" supertip="YouTubeの動画を挿入します。">
          <!-- image by : Erlen Masson - http://erlen.co.uk/ -->
          <button id="btnYouTubeInsert" label="YouTube 挿入" size="large" image="YouTubeIcon" onAction="btnYouTubeInsert_onAction" screentip="YouTubeの動画挿入" supertip="YouTubeの動画を現在のスライドに挿入します。" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

■ 関連Webページ

・PowerPoint 2013 で YouTube から動画を挿入したい【対処編】
http://snow-white.cocolog-nifty.com/first/2013/09/powerpoint-20-2.html