Google スライドで新規プレゼンテーションを作成するVBAマクロ

ホーム
Office関連, Excel, Word, PowerPoint, Google関連
Google スライドで新規プレゼンテーションを作成するVBAマクロ

Office関連

2018.09.6

Google スライドで新規プレゼンテーションを作成するVBAマクロ

ここ数日PowerPointのマクロに加え、Google Apps ScriptからGoogle スライドを取り扱う方法について記事を書いてきました。

2018.09.05

選択中の図形の文字列を蛍光ペンでハイライトするPowerPointマクロ

MSDNフォーラムに「PowerPoint 2016で、マクロで選択中の図形をハイライトすると、文字列の書式が勝手に変わってしまう」といった質問がありました。確認してみると、たしかに先頭の文字の書式が後の文字にまで反映されてしまっているようです。 ...

2018.09.05

[Google Apps Script]Google スライドでスクリプトを実行する

最近私の周りでPowerPoint VBAがひっそりと流行中です。 Excelのマクロに比べて注目される機会が少なかったPowerPointマクロに焦点が当たるのは中々面白い流れですね！ “乗るしかない、このビッグウェーブに”、ということで、私もこの流...

こう来ると、次はPowerPointマクロからGoogle スライドを弄ろうというのはごく自然な流れかと思います。

そこで今回は、VBAマクロからGoogle スライドで新規プレゼンテーションを作成する方法を紹介します。

Google Slides API

Google スライドには、外部からプレゼンテーションを操作するためのAPI「Google Slides API」が用意されています。

.NETやPHPといった一般的な言語にはライブラリが用意されているので比較的APIも呼び出しやすいのですが、VBAにはもちろんライブラリが用意されていないので自力で実装する必要があります。

APIの呼び出しにあたっては、Authorization Codeを取得してAccess Tokenを取得して…といったフローが必要なのですが、ここでは深く解説しません。
YouTube Data APIのガイドになりますが、下記ページが比較的分かりやすくまとまっているので、参考にしていただければと思います。

Google Developers

OAuth 2.0 Flow: Installed apps | YouTube Data API (v3) &nbsp...

https://developers.google.com/youtube/v3/guides/auth/installed-apps?hl=ja

下準備

APIを呼び出す前に、まずは「クライアント ID」と「クライアントシークレット」が必要になります。
前回書いた下記記事を参考に、この2つを取得してください。

2018.09.06

【2018年9月版】Google API ConsoleでクライアントIDとクライアントシークレットを取得する方法

GoogleのAPIを呼び出すにあたり、クライアントIDとクライアントシークレットが必要な場合があります。当ブログでもその取得方法についていくつか記事を書いてきたのですが(下記参照)、管理画面のUIの変更により、古い情報が使えなくなることがよくあります。 ...

クライアント IDとクライアントシークレットの準備ができたら、「Google Slides API」を有効にします。

APIライブラリ(https://console.developers.google.com/apis/library)にアクセスし、Google アカウントでログインします。
「プロジェクトの選択」プルダウンのプロジェクトが使用するプロジェクトになっていることを確認します。

「slide」をキーワードに検索すると、「Google Slides API」がヒットするのでAPIを有効にします。

以上で準備作業は完了です。

Google スライドで新規プレゼンテーションを作成するVBAマクロ

次はいよいよコードです。
クライアント IDとクライアントシークレットはそれぞれ自分のものに置き換えてください。
また、下記コードはScriptControlを使用しているため、64ビット版のOfficeでは動作しませんので、その点も注意が必要です。

'※ScriptControlを使用しているため、64ビット版のOfficeでは動作しません。
Option Explicit

'--------------------------------------------------
'※要変更
'--------------------------------------------------
Private Const client_id As String = "(クライアント ID)"
Private Const client_secret As String = "(クライアント シークレット)"
'--------------------------------------------------
 
Private Const redirect_uri As String = "urn:ietf:wg:oauth:2.0:oob"
Private Const response_type As String = "code"
Private Const grant_type As String = "authorization_code"

Public Sub CallSlidesAPI()
  Dim ret As String
  
  ret = CreateNewPresentation("新規プレゼンテーション")
  If Len(Trim(ret)) > 0 Then
    MsgBox "presentationId:" & ret, vbInformation + vbSystemModal, "処理成功"
  Else
    MsgBox "処理が失敗しました。", vbExclamation + vbSystemModal
  End If
End Sub

Public Function CreateNewPresentation(ByVal title As String) As String
'新規プレゼンテーション作成
  Dim auth_code As String
  Dim access_token As String
  Dim presentation_id As String
  Dim res As String
  Dim json As Object
  Dim dat As Variant
  Const scopes As String = "https://www.googleapis.com/auth/drive%20https://www.googleapis.com/auth/presentations"
  Const presentation_uri As String = "https://slides.googleapis.com/v1/presentations"
  
  'Authorization Code取得
  auth_code = GetAuthorizationCode(scopes)
  If Len(Trim(auth_code)) < 1 Then Exit Function
  
  'Access Token取得
  access_token = GetAccessToken(auth_code)
  If Len(Trim(access_token)) < 1 Then Exit Function
  
  'API実行
  dat = "{""title"": """ & title & """}"
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", presentation_uri, False
    .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
    .SetRequestHeader "Authorization", "Bearer " & access_token
    .Send dat
    Select Case .Status
      Case 200:
        res = "(" & .responseText & ")"
        With CreateObject("ScriptControl")
          .Language = "JScript"
          Set json = .Eval(res)
          If Not json Is Nothing Then presentation_id = VBA.CallByName(json, "presentationId", VbGet)
        End With
    End Select
  End With
  CreateNewPresentation = presentation_id
End Function

Private Function GetAuthorizationCode(ByVal scopes As String) As String
'Authorization Code取得
  Dim ie As Object
  Dim url As String
  Dim iptCode As Object
  Dim auth_code As String
  Const READYSTATE_COMPLETE = 4
  
  '初期化
  Set ie = Nothing: Set iptCode = Nothing
  
  url = "https://accounts.google.com/o/oauth2/auth?" & _
        "client_id=" & client_id & _
        "&redirect_uri=" & redirect_uri & _
        "&scope=" & scopes & _
        "&response_type=" & response_type
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Visible = True
    .AddressBar = False
    .MenuBar = False
    .StatusBar = False
    .Toolbar = False
    .Width = 600
    .Height = 480
    .Navigate url
    
    '承認待ち
    Do
      DoEvents
    Loop While InStr(LCase(.LocationURL), "accounts.google.com/o/oauth2/approval") < 1
    
    'Authorization Code取得待ち
    On Error Resume Next
    Do
      Set iptCode = .Document.getElementById("code")
      DoEvents
    Loop While iptCode Is Nothing
    On Error GoTo 0
    auth_code = iptCode.Value
    
    'ログアウト
    .Navigate "https://accounts.google.com/Logout"
    While .Busy Or .readyState <> READYSTATE_COMPLETE
      DoEvents
    Wend
    .Quit
  End With
  GetAuthorizationCode = auth_code
End Function

Private Function GetAccessToken(ByVal auth_code As String) As String
'Access Token取得
  Dim access_token As String
  Dim res As String
  Dim json As Object
  Dim dat As Variant
  
  dat = "code=" & auth_code & _
        "&client_id=" & client_id & _
        "&client_secret=" & client_secret & _
        "&redirect_uri=" & redirect_uri & _
        "&grant_type=" & grant_type
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", "https://accounts.google.com/o/oauth2/token", False
    .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .Send dat
    Select Case .Status
      Case 200:
        res = "(" & .responseText & ")"
        With CreateObject("ScriptControl")
          .Language = "JScript"
          Set json = .Eval(res)
          If Not json Is Nothing Then access_token = VBA.CallByName(json, "access_token", VbGet)
        End With
    End Select
  End With
  GetAccessToken = access_token
End Function