Office関連

「クイックアクセスツールバーからPowerPointマクロを実行するアドイン」のコード

2年ほど前に書いたPowerPointマクロの記事「クイックアクセスツールバーからPowerPointマクロを実行するアドインの紹介」に対して、アドインのコードを見たいというコメントがあったので、コードをそのまま載せることにします。

・リボンXML

<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <ribbon>
    <tabs>
      <tab id="tabCallProc" label="マクロ呼出" visible="false">
        <group id="grpCallProc" label="マクロ呼出">
          <dynamicMenu id="dmuCallProc" label="マクロ呼出" imageMso="VisualBasic" size="normal" screentip="マクロ呼出メニュー" supertip="登録されたアドインのマクロを実行します。" getContent="dmuCallProc_getContent" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

・標準モジュール

Option Explicit

Public Sub dmuCallProc_getContent(control As IRibbonControl, ByRef returnedVal)
  Dim DataFilePath As String
  Dim buf As String
  Dim ff As Integer
  Dim d As Object
  Dim elmMenu As Object
  Dim elmButton As Object
  Dim v As Variant
  Dim i As Long
  Dim j As Long
  
  Const MyAddInName As String = "CallProcAddin" 'このアドイン名
  Const DataFileName As String = "macrodat.txt" 'マクロデータ名
  Const BtnID As String = "btnCallProc"
  
  On Error Resume Next
  If Application.AddIns(MyAddInName).Loaded <> msoTrue Then
    MsgBox "アドインが読み込まれていません。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
    Exit Sub
  End If
  On Error GoTo 0
  
  DataFilePath = Application.AddIns(MyAddInName).Path
  If Right$(DataFilePath, 1) <> "\" Then DataFilePath = DataFilePath & "\"
  DataFilePath = DataFilePath & DataFileName
  Set d = CreateObject("Msxml2.DOMDocument")
  Set elmMenu = d.createElement("menu")
  elmMenu.setAttribute "xmlns", "http://schemas.microsoft.com/office/2006/01/customui"
  elmMenu.setAttribute "itemSize", "normal"
  If Len(Dir$(DataFilePath)) < 1 Then
    Set elmButton = d.createElement("button")
    With elmButton
      .setAttribute "id", BtnID
      .setAttribute "label", "マクロデータが見つかりません。"
      .setAttribute "imageMso", "QueryRunQuery"
      .setAttribute "screentip", "マクロデータが見つかりません。"
      .setAttribute "supertip", "[" & DataFilePath & "]ファイルがあるかどうかご確認ください。"
    End With
    elmMenu.appendChild elmButton
    Set elmButton = Nothing
  Else
    i = 1: j = 1 '初期化
    ff = FreeFile
    Open DataFilePath For Input As #ff
    Do Until EOF(ff)
      Line Input #ff, buf
      If Len(buf) > 0 Then
        v = Split(buf, ";")
        'Debug.Print "AddInName:" & v(0), "Caption:" & v(1), "MacroName:" & v(2)
        If j > 9 Then j = 1
        Set elmButton = d.createElement("button")
        With elmButton
          .setAttribute "id", BtnID & CStr(i)
          .setAttribute "label", v(1) & "(" & ChrW(38) & CStr(j) & ")"
          .setAttribute "imageMso", "MacroRun"
          .setAttribute "screentip", "アドイン名:" & v(0)
          .setAttribute "supertip", "マクロ名:" & v(2)
          .setAttribute "tag", v(0) & "|" & v(2)
          .setAttribute "onAction", BtnID & "_onAction"
        End With
        elmMenu.appendChild elmButton
        Set elmButton = Nothing
        i = i + 1
        j = j + 1
      End If
    Loop
    Close #ff
  End If
  d.appendChild elmMenu
  returnedVal = d.XML
End Sub

Public Sub btnCallProc_onAction(control As IRibbonControl)
  Dim v As Variant
  
  On Error Resume Next
  v = Split(control.Tag, "|")
  Application.Run v(0) & "!" & v(1)
  If Err.Number <> 0 Then
    MsgBox "エラーが発生しました。" & vbCrLf & vbCrLf & _
           "エラーNo:" & Err.Number & vbCrLf & _
           "エラー情報:" & Err.Description, vbCritical + vbSystemModal
    Err.Clear
  End If
  On Error GoTo 0
End Sub

久しぶりに引っ張り出してきたファイルなので、上記コードが最新版かどうかは分かりませんが(^^; 、基本的な仕組みは変わっていないはずです。

dynamicMenu要素のgetContent属性のコールバックで動的にXMLを読み込んで、テキストファイルに記述されたマクロを実行する形ですね。

[雑感]Office 365 Soloに向く人、向かない人前のページ

Officeの新製品発売記念イベントに参加してきました。次のページ

関連記事

  1. Office関連

    “元に戻す”履歴に文字列をセットするPowerPointマクロ

    PowerPointマクロでは、Presentationオブジェクトの…

  2. Office関連

    Office 2016でACROBATタブが表示されない!?(Acrobat DC)

    2015/10/16 追記:先日公開されたアップデート「15.00…

  3. Office関連

    goo.glで短縮URLを取得するVBAマクロ

    何年か前にHPで「goo.glで短縮URLを取得する」マクロを紹介しま…

  4. Office関連

    モヤさまのショウ君にいろいろ喋らせるVBAマクロ(1)

    「「VoiceText Web API」(β版) の提供を開始」にある…

コメント

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

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

Time limit is exhausted. Please reload CAPTCHA.

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

Translate

最近の記事

アーカイブ

PAGE TOP