Office関連

スライド内容を自動的に機械翻訳するPowerPointマクロ

前回の記事で紹介した各スライドに配置されたオートシェイプからテキストを取得するPowerPointマクロと以前紹介したGoogle翻訳で文字列を翻訳するマクロを組み合わせて、スライド内容を自動的に機械翻訳するマクロを作ってみます。

Option Explicit

Public Sub Sample()
  Dim sld As PowerPoint.Slide
  Dim shp As PowerPoint.Shape
  Dim gshps As PowerPoint.GroupShapes
  Dim tmpsld As PowerPoint.Slide
  Dim tmpvt As PowerPoint.PpViewType
  
  If Application.SlideShowWindows.Count > 0& Then Exit Sub
  tmpvt = Application.ActiveWindow.ViewType
  Application.ActiveWindow.ViewType = ppViewNormal
  Set tmpsld = Application.ActivePresentation.Slides.FindBySlideID _
  (Application.ActivePresentation.Windows(1).Selection.SlideRange.SlideID)
  For Each sld In Application.ActivePresentation.Slides
    For Each shp In sld.Shapes
      Set gshps = Nothing
      On Error Resume Next
      Set gshps = shp.GroupItems
      On Error GoTo 0
      If gshps Is Nothing Then
        SortShape shp
      Else
        SortGroupShape gshps
      End If
    Next
  Next
  tmpsld.Select
  Application.ActiveWindow.ViewType = tmpvt
  Debug.Print "処理が終了しました。"
End Sub

Private Sub SortGroupShape(ByVal gshps As PowerPoint.GroupShapes)
'グループ化されたシェイプの振り分け
  Dim shp As PowerPoint.Shape
  Dim subgshps As PowerPoint.GroupShapes
  
  For Each shp In gshps
    Set subgshps = Nothing
    On Error Resume Next
    Set subgshps = shp.GroupItems
    On Error GoTo 0
    If subgshps Is Nothing Then
      SortShape shp
    Else
      SortGroupShape subgshps
    End If
  Next
End Sub

Private Sub SortShape(ByVal shp As PowerPoint.Shape)
'シェイプの振り分け
  Dim n As Office.SmartArtNode
  Dim clm As PowerPoint.Column
  Dim c As PowerPoint.Cell
    
  Select Case shp.Type
    Case msoSmartArt
      For Each n In shp.SmartArt.Nodes
        If n.TextFrame2.HasText = True Then MainProcSmartArtNode n
      Next
    Case msoTable
      For Each clm In shp.Table.Columns
        For Each c In clm.Cells
          If c.Shape.TextFrame.HasText = True Then MainProcShape c.Shape
        Next
      Next
    Case Else
      If shp.TextFrame.HasText = True Then MainProcShape shp
  End Select
End Sub

Private Sub MainProcShape(ByRef shp As PowerPoint.Shape)
  shp.TextFrame.TextRange.Text = TranslateGoogle(shp.TextFrame.TextRange.Text, "ja", "en")
End Sub

Private Sub MainProcSmartArtNode(ByRef nd As Office.SmartArtNode)
  nd.TextFrame2.TextRange.Text = TranslateGoogle(nd.TextFrame2.TextRange.Text, "ja", "en")
End Sub

Private Function TranslateGoogle(ByVal target As String, Optional ByVal FromLng As String = "auto", Optional ByVal ToLng As String = "en") As String
  Dim dat As Variant
  Dim ret As String
  Dim js As String
  Dim itm As Object
  Dim cnt As Long
  Dim sentences, length '小文字表示用ダミー
  Const url As String = "http://translate.google.com/translate_a/t"
  
  ret = "": js = "": cnt = 1 '初期化
  dat = "client=0&sl=" & FromLng & "&tl=" & ToLng & "&text=" & EncodeURL(target)
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", url, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .Send dat
    If .Status = 200 Then js = .responseText
  End With
  On Error GoTo 0
  If Len(js) > 0 Then
    js = "(" & js & ")"
    With CreateObject("ScriptControl")
      .Language = "JScript"
      On Error Resume Next
      For Each itm In .CodeObject.eval(js).sentences
        If cnt = 1 Then
          ret = ret & itm.trans
        Else
          ret = ret & vbCrLf & itm.trans
        End If
        cnt = cnt + 1
      Next
      On Error GoTo 0
    End With
  End If
  TranslateGoogle = ret
End Function

Private Function EncodeURL(ByVal sWord As String) As String
  With CreateObject("ScriptControl")
    .Language = "JScript"
    EncodeURL = .CodeObject.encodeURIComponent(sWord)
  End With
End Function

コード自体は上記記事中のマクロをほぼそのまま流用しているだけです。
また、グラフについては処理が複雑になるので今回は無視しました。

上記コードを実行すると下図のような日本語のスライドが、

自動的に翻訳が行われすぐに英語のスライドへと変更されます。

翻訳はすべてGoogle翻訳に依存しているため、同サービスが使用できなくなると上記マクロも利用することができなくなります。
半ば無理やり処理を行っているため、上記コードを業務用やその他重要なマクロの中に実装することはお薦めしません(翻訳精度についても私は一切保証しません)。
あくまでも、こういったことも一応できる、という参考程度に留めておいてください。

各スライドに配置されたオートシェイプからテキストを取得するPowerPointマクロ前のページ

Adobe Reader XIを利用してPDFファイルのページ数を取得するVBAマクロ次のページ

関連記事

  1. Office関連

    代理人アクセスによって予定を追加するOutlookマクロ

    先日久々にmougの質問に回答しました。マクロを使って、Exc…

  2. Office関連

    Excel Services JavaScript APIを試してみました(1)

    前回の記事で紹介した「ExcelMashup.com」、このサイトによ…

  3. Office関連

    ルビ(ふりがな)を一括設定するWordマクロ(改良版)

    これまで当ブログではルビを設定するWordマクロについて、いくつか記事…

  4. Office関連

    Microsoft Graph ExplorerがMicrosoft アカウント(MSA)に対応しま…

    Azure AD v2.0 エンドポイントによって、個人用Micros…

  5. Office アドイン

    [Office用アプリ]Google ドライブでアプリを公開する方法

    今回は先日登壇した第一回 Apps for Office 勉強会の中で…

  6. Office関連

    PowerPoint 2013ではプレゼンテーションをmp4形式で保存できるようになりました。

    ※ この情報はOffice 2013 カスタマー プレビュー版を元にし…

コメント

  1. この記事へのコメントはありません。

  1. この記事へのトラックバックはありません。

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP