2018年5月13日 / 最終更新日時 : 2021年12月30日 officeの杜 msoffice

ExcelとAccessに独自のリボンを追加する

Officeにて業務用アプリケーションを構築する時に、いつも課題になるのが「ボタンや入力用UIをどうするか？」で悩みます。Accessの場合には、フォームを作るのが定石なので、それほど困らないのですが、Excelの場合はシートの上にボタンを置くというのも、格好が悪いのと、列が多い場合、置き場所に困ります。

また、複数ウィンドウがあると、ボタンへのアクセスがしにくくなります。そこで利用するのが色々悪名高いリボン。しかし、登場からもう10数年経過して割りと受け入れられてきてるとも思います。今回は、このリボンに自分が作ったVBAコマンドなどを割り当てて動かせるように構築しようと思います。

今回使用するファイル

WYSIWYGでリボンを作成するOffice2010 RibbonCreatorというソフトウェアもありますが、こちらはシェアウェアとなっています。また、Visual Studio for OfficeでもGUIでリボンを作成できるようです。

Excelにリボンを追加する

Excelファイルにリボンを追加するのは少々厄介です。まずリボンが追加出来るのは、VBAが利用出来る拡張子がxlsm形式やxlam形式である事が必要です。事前にxlsm形式等でファイルを保存しておきましょう。また、XMLファイルが必要ですが、xlsmをLhazなどのアーカイバで解凍すると色々出てきます。この中に「customUI」というフォルダを作り、その中に「customUI.xml」と「customUI14.xml」の２つのファイルを作るのですが、最期はZIPで固め直すという面倒が作業が必要です。

そこで利用するのが、Custom UI Editor Toolです。まずはこれを使えるようにしましょう。

※なおこのツールは、WordやPowerPointにも使えるので、pptmファイルにリボンを付けることも可能です。

Custom UI Editor Tool

Custom UI Editor Toolをまずはインストールしましょう。以下の手順で準備します。このエディタは、Excel、Word、PowerPointに対応しているのは確認しています。

サイトに行き、Clone or Downloadをクリックする
Download ZIPをクリックする
ダウンロードされたZIPファイルを解凍する
解凍された中のフォルダ「Publish」⇒「Application Files」⇒「CustomUIEditor_4_0_0_0」を開く
CustomUIEditor.exe.deployというファイルがあるので、名前変更で、.deployを削る
CustomUIEditor.exeに対するショートカットをデスクトップにでも作る
ちょっと日本語入力にオカシナ点がある・・・・

Setup.exeがあるのですが、ビルドに失敗してるのか！？起動しても何もおきないのでこの方法でexeファイルを起動します。

図：Custom UI Editor Toolを起動してみた

起動時初期化のコード

リボンを定義する前に、初期化する為のコードなどをExcel側に用意しておきましょう。標準モジュールを追加して、以下のコードを用意しておきます。

Public m_ribbon As IRibbonUI

'リボン起動時に初期化するコード
Public Sub OnLoad(ribbon As IRibbonUI)
    'リボンのインスタンスを取得
    Set m_ribbon = ribbon

    '自作のリボンをアクティブにする
    m_ribbon.ActivateTab ("SampleTab")
End Sub

'タブの表示状態を取得する
Public Sub Tab_getVisible(control As IRibbonControl, ByRef returnedVal)
    '常にタブを表示する
    returnedVal = True
End Sub

'メッセージを表示するリボンコマンドから叩く処理
Public Sub hello(ByVal control As IRibbonControl)
    MsgBox "Hello World!"
End Sub

Public m_ribbon As IRibbonUI

'リボン起動時に初期化するコード

Public Sub OnLoad(ribbon As IRibbonUI)

'リボンのインスタンスを取得

Set m_ribbon = ribbon

'自作のリボンをアクティブにする

m_ribbon.ActivateTab ("SampleTab")

End Sub

'タブの表示状態を取得する

Public Sub Tab_getVisible(control As IRibbonControl, ByRef returnedVal)

'常にタブを表示する

returnedVal = True

End Sub

'メッセージを表示するリボンコマンドから叩く処理

Public Sub hello(ByVal control As IRibbonControl)

MsgBox "Hello World!"

End Sub

OnLoadという関数が肝です。リボン初期化時にこのコードが読み込まれ、リボンのインスタンスを取得します。ここでしか取得できず、取得しておかないと後でリボンをコントロール出来なくなります。また、今回は自作リボンを起動時にアクティブにしています。

また、リボンのボタンが直接叩く「hello」という関数を作っておきました。

リボンを作成する

早速リボンを作成します。Custom UI Editor Toolを起動し、Openでxlsmファイルを開きましょう。開いた初期の状態では何も入っていない状態のはずです。メニューより「Insert」⇒「office2010 Custom UI Part」をクリックしましょう。これでXMLが書けるようになります。作成したら、以下のサンプルコードを貼り付けてみましょう。

サンプルコード

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" xmlns:mso="http://schemas.microsoft.com/office/2009/07/customui" 
onLoad="OnLoad">
  <ribbon>
    <tabs>
      <tab id="SampleTab" label="マクロツール" getVisible="Tab_getVisible">
        <group id="toolgroup" label="変換ツール" centerVertically="true">
	    <button id="customButton" label="処理の実行" imageMso="ProposeNewTime" size="large" onAction="hello" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" xmlns:mso="http://schemas.microsoft.com/office/2009/07/customui"

onLoad="OnLoad">

<tabs>

</group>

</tab>

</tabs>

</ribbon>

</customUI>

リボンはボタンだけでなく、テキストボックスやドロップダウンなど色々なパーツを作り込むことができますが、今回はまずシンプルに1個のタブと1個のグループ、1個のボタンだけで構成しています。1行目ラストにはonLoad="OnLoad"を追加し、初期化コードを実行させます。

また、buttonのonActionには作成済み関数であるhelloを指定してあげています。

imageMsoについて

imageMsoはボタンなどで使う予め用意されているアイコン画像です。アイコン名を入れる事で予め用意されてるアイコン類を使えるのですが、imageMso Gallaryにてどんな画像があるのか調べる事が可能です（但し、Office2010とOffice2016ではアイコンのデザインが大分異なります）

また、ここに独自の画像（PNGファイルなど）を使う事も可能です。もちろん、Custom UI Editorから画像を挿入し、ファイル名の拡張子を除いたものをimageに指定することで独自画像をボタンに使用する事が可能です。

Custom UI Editorでxlsmファイルを開く
リボンを追加し、Insert Iconでjpgやpngファイルを開く
左のパネルにあるcustom14UI.xmlの中に画像が登録される
imageMso=ではなく、image="tomato"といった形で指定する。拡張子は付けない。

図：Custom UI Editorで簡単に独自画像が追加できる

主に使うパーツ

自分がよく使うパーツをピックアップしてみました。上記では必要最低限度のパーツのみでXMLに記述しましたが、主に今後開発を進めていくに当たってよく使うパーツのコードを記述してみました。

チェックボックスやテキストボックスなどもありますが、あまりリボンで作り込む時には適さないので、自分は使用していません。

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" xmlns:mso="http://schemas.microsoft.com/office/2009/07/customui" onLoad="OnLoad">
  <ribbon>
    <tabs>
      <tab id="SampleTab" label="マクロツール" getVisible="Tab_getVisible">
        <group id="toolgroup" label="変換ツール" centerVertically="true">
	    <button id="customButton" label="処理の実行" imageMso="ProposeNewTime" size="large" onAction="hello" />
        </group>
	  <group id="fileman" label="ファイル">
	  	<menu id="menu1" label="データの&#xD;エクスポート" itemSize="large" imageMso="ExportExcel" size="large">
			<button id="customButton2" label="処理の実行" imageMso="ProposeNewTime" onAction="hello" />
			<button id="customButton3" label="認証実行" imageMso="AppointmentColorDialog" onAction="auth" />
			<button id="customButton4" label="チョイス" imageMso="FileManageMenu" onAction="selection" />
			<menuSeparator id="menuSeparator1" title="以下サブメニュー" />
			<menu id="menu2" label="データの&#xD;エクスポート" itemSize="large" imageMso="ExportExcel">
					<button id="customButton5" label="サブメニューだよ" imageMso="SmartArtChangeColorsGallery" onAction="subproc" description="エクセルで出力しますよ"/>
			</menu>
		</menu>
	  </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

<tabs>

</group>

</menu>

</group>

</tab>

</tabs>

</ribbon>

</customUI>

気をつけなければならない点は

各パーツ類のidは重複してはなりません。
menu属性の場合、その親のitemSizeに従うので、Buttonにはsize属性は付けない

この2点はコピペ時にしょっちゅう引っかかるポイントです。きちんと確認しましょう。

図：サブメニューなどを追加してみた

Accessにリボンを追加する

Accessの場合、WordやExcel、PowerPointとはアプリケーションの構造自体が異なり、リボン自体の組み込み方も異なります。XML形式で定義するのは同じなのですが、この組み込み部分がややこしいです。

図：サブメニューや大きなメニューを使うと雰囲気アップ

Usysribbonsテーブルを作る

リボンはテーブルで作ります。まずは以下の形式でテーブルを隠しオブジェクトとして作ります。

IDはオートナンバー（値は1）
RibbonNameは短いテキスト型（値は適当にリボン名を入力）
RibbonXmlは長いテキスト型（XML構造定義をここに記述）

作成後に、以下の手順で起動時にこのリボンが表示されるように設定します。

メニューより「ファイル」⇒「オプション」を開く
現在のデータベースを開く
リボンとツールバーのオプションの項目に移動する
リボン名のドロップダウンリストに上記で設定したリボン名が出て来るので選択する。
OKボタンを押して、Accessを再起動

Usysribbonsテーブルは隠しオブジェクトにしておくべきですので、左サイドバーより

Usysribbonsテーブルを右クリック
テーブルのプロパティを開く
属性の隠しオブジェクトにチェックを入れてOKボタンをクリック

図：Usysribbonsテーブルの構造

起動時初期化のコード

リボンを定義する前に、リボンを初期化する為のコードを事前に用意しておきましょう。標準モジュールを追加しておいて、以下のコードを用意しておきます。また、Accessで独自リボンを使う場合には、Microsoft office15 Object Libraryへの参照設定が必要です。

Option Compare Database
Public myRibbon As IRibbonUI

'起動時にリボンの挙動を制御する
Public Sub onLoad(ribbon As IRibbonUI)
    'リボンのインスタンスを取得しておく
    Set myRibbon = ribbon

    'カスタムタブをアクティブにする
    ribbon.ActivateTab "CustomTab" 
End Sub

'印刷プレビュー時にタブをアクティブにするコード
Public Sub ActivateTabPreview()
  On Error Resume Next
  Call myRibbon.ActivateTabMso("TabPrintPreviewAccess")
End Sub

'自分で作ったタブをアクティブにするコード
Public Sub CustomTabActive()
  Call myRibbon.ActivateTab("CustomTab")
End Sub

Option Compare Database

Public myRibbon As IRibbonUI

'起動時にリボンの挙動を制御する

Public Sub onLoad(ribbon As IRibbonUI)

'リボンのインスタンスを取得しておく

Set myRibbon = ribbon

'カスタムタブをアクティブにする

ribbon.ActivateTab "CustomTab"

End Sub

'印刷プレビュー時にタブをアクティブにするコード

Public Sub ActivateTabPreview()

On Error Resume Next

Call myRibbon.ActivateTabMso("TabPrintPreviewAccess")

End Sub

'自分で作ったタブをアクティブにするコード

Public Sub CustomTabActive()

Call myRibbon.ActivateTab("CustomTab")

End Sub

とりわけ、onLoadはリボン読み込み時にだけ実行される特別な関数で、ここでリボンのインスタンスを取得しておかないと、移行リボンのコントロールが出来ないので必須のコマンドです。また、Accessの場合はオリジナルのリボンをまず表示するのが定石なので、この段階で自作リボンをアクティブにしています。

リボンを作成する

基本的にはExcelの場合と同じです。少し異なる点は、onActionにマクロを指定できる点です。マクロを指定する場合は、onActionにマクロ名を入れるだけです。関数を直接叩く場合には、関数名を入れますがその関数はExcelの場合と同じ様式で作成します。

起動時に初期化する

onLoadという関数を事前に用意しましたが、XML内でこれを読み込み時に実行するように追加します。

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">

1	<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">

1行目のcustomUIの項目に、onLoad="onLoad"として追加します。これで自動で実行されるようになります。

ボタンの実行に関数を割り当て

<button id="ButtonX" imageMso="ShowTimeZones" size="large" label="全体表示&#xD;" screentip="データの表示" onAction="testribbon" />

1	<button id="ButtonX" imageMso="ShowTimeZones" size="large" label="全体表示 " screentip="データの表示" onAction="testribbon" />

idにはButtonXを指定。onActionにはtestribbonを指定しました。testribbonという名前のマクロを用意した場合には、そちらが実行されるようになります。

実行用のコード

上記のときの直接実行コードは以下のように作ります。

'リボン用直接実行関数
Public Sub testribbon(control As IRibbonControl)
    Select Case control.ID
        Case "ButtonX":
        MsgBox "test"
    End Select
End Sub

'リボン用直接実行関数

Public Sub testribbon(control As IRibbonControl)

Select Case control.ID

Case "ButtonX":

MsgBox "test"

End Select

End Sub

control.IDで押されたボタンのIDを取得しています。この時、ButtonXならばメッセージボックスを表示してくれます。

ボタンの幅などのTips

普通にそのまま、リボンを作ってると、ボタンの幅が狭く、リボンのラベルが妙な所で改行！？されたような不細工な表示になることがままあります。自分としては綺麗に表示したいのに制御が出来ません。これを制御する方法は、ラベルの改行したい場所に「」という文字を入れることで、改行が可能になります。

すると綺麗に幅が調整されてボタンの見た目もGoodになります。

チェックボックスを利用する

業務でどうしても設定ダイアログではなく、リボンでオプション切り替えできるようにして欲しいという事でしたので、計算や実行をする際に切り替える為のオプションとして「チェックボックス」をリボンに追加し、チェック内容をフラグにして条件分岐し計算結果を変動させる仕組みを作りました。ボタンと違って、オンオフのロジックが必要となるので、少々難易度が高いです。

もちろん、ExcelやPowerPointなどでも利用する事は可能です。

図：ラジオボタンは存在しない

リボンXMLについて

チェックボックスのリボン自体はそこまで難しくはありません。しかし、チェック状態の取得やチェックされた時のアクション、そしてその値を格納する変数等が必要になるので、単純ではありません。

<group id="options" label="オプション">
	<checkBox id="sagaku" label="差額列のみをエクスポート" getPressed="chkSample_getPressed" onAction="chkSample_onAction" visible="false" />
	<checkBox id="chksagakuonly" label="全員差額が0の列は非表示" getPressed="chkSagaku_getPressed" onAction="chkSagaku_onAction" />
	<checkBox id="chksagakuzero" label="全差額が0のレコードは出力しない" getPressed="chkZero_getPressed" onAction="chkZero_onAction" />
</group>

</group>

getPressedがチェック状態を取得するイベントになります。引数がその関数となる
onActionがチェックした時のイベントになり、引数がその関数となる。
今回初期値や、その後チェックされた場合にはiniファイルへとチェック状態を保存するようにしています。

チェックボックスのロジック

チェックボックスは、リボンが読み込まれた時にチェック状態を取得する為のgetPressedというアクション、そしてその後のチェックをした時のonActionの２つで構成されています。

今回、前述のXMLのうち、chksagakuonlyにあるアクションについて、以下に記してみました。それぞれ、chkSagaku_getPressed関数とchkSagaku_onAction関数が担当しています。前者はリボン読み込み時の初回のみ、後者は随時実行されることになります。

'データ書き込みカウンタやフラグ
Private flgSagaku As Boolean

'チェックボックスの状態を格納する
Public isSagaku As Boolean

'起動時にリボンの挙動を制御する
Public Sub ribbonman(ribbon As IRibbonUI)

　・・・・前略・・・・

　'チェックボックスの初期値設定
  flgSagaku = IniRead("USER", "OP2", "")

　'変数にも格納する
　isSagaku = flgSagaku
end sub

'checkBox要素のON・OFFを設定
Public Sub chkSagaku_getPressed(control As IRibbonControl, ByRef returnedVal)
　'flgSagakuからチェック状態を取得し、リボンへ返す
  returnedVal = flgSagaku
  
  'チェックボックスの初期値を格納
  isSagaku = flgSagaku
End Sub

'チェックボックスをクリックした時の動作
Public Sub chkSagaku_onAction(control As IRibbonControl, pressed As Boolean)
'checkBox要素クリック時に実行
  flgSagaku = Not flgSagaku
  
  'pressedの判定を行う
  If pressed = True Then
    MsgBox "差額のある列のみを表示するようにします", vbSystemModal
  Else
    MsgBox "全てのレコードをエクスポートします", vbSystemModal
  End If
  
  'チェックボックスの状態を格納する
  isSagaku = pressed
  
  'iniファイルにも書き込む
  IniWrite "USER", "OP2", pressed
End Sub

'データ書き込みカウンタやフラグ

Private flgSagaku As Boolean

'チェックボックスの状態を格納する

Public isSagaku As Boolean

'起動時にリボンの挙動を制御する

Public Sub ribbonman(ribbon As IRibbonUI)

　・・・・前略・・・・

　'チェックボックスの初期値設定

flgSagaku = IniRead("USER", "OP2", "")

　'変数にも格納する

　isSagaku = flgSagaku

end sub

'checkBox要素のON・OFFを設定

Public Sub chkSagaku_getPressed(control As IRibbonControl, ByRef returnedVal)

　'flgSagakuからチェック状態を取得し、リボンへ返す

returnedVal = flgSagaku

'チェックボックスの初期値を格納

isSagaku = flgSagaku

End Sub

'チェックボックスをクリックした時の動作

Public Sub chkSagaku_onAction(control As IRibbonControl, pressed As Boolean)

'checkBox要素クリック時に実行

flgSagaku = Not flgSagaku

'pressedの判定を行う

If pressed = True Then

MsgBox "差額のある列のみを表示するようにします", vbSystemModal

Else

MsgBox "全てのレコードをエクスポートします", vbSystemModal

End If

'チェックボックスの状態を格納する

isSagaku = pressed

'iniファイルにも書き込む

IniWrite "USER", "OP2", pressed

End Sub

リボンロード時にまず、ribbonmanが呼び出され、チェック状態をiniファイルから読み込み
チェック状態を取得したら、returnedValとして対象のチェックボックスへ値を返して上げる
チェック時はiniファイルへ書き込みをすると同時に、管理している変数へ保存する

実際にメインとなるルーチンで使う場合には、リボンの状態を取得するのではなく、この変数に格納されている値を利用して、条件分岐させプログラムを書く事になります。今のリボンのコントロールの状態を随時読み出すのは非常に厄介なので。

トグルボタンを利用する

チェックボックスの場合、見ての通り小さいコントロールなので、今オンなのかオフなのかわかりにくいという特性があります。なので、頻繁に切り替えて使うようなシーンでは、ミスを生む可能性が非常に高いです。そこで利用するのがトグルボタンコントロールで、オンオフ状態をスイッチのように切替える事を表現したコントロールになります。

今回このコントロールのオンオフ時に於ける「画像」と「ラベル」も同時に変更して、モードチェンジを実現してみたいと思います。結構複雑なロジックになります。

トグルボタンのXML

今回のケースでは、トグルの状態やトグル変更時の他に、その際のトグルのラベルや画像も動的に切り替える必要があるため殆どの項目にアクションを付けてあげる必要があります。

<group id="group1" label="モードチェンジ" keytip="A">
  <toggleButton id="modeman" getLabel="getLabel" keytip="C" getImage="getButtonImage" size="large" onAction="toggleButton_onAction" getPressed="getPressed" description="前月当月か？当月同士で比較するかのモードを変更します。" />
</group>

</group>

getLabelが動的にその時点でのラベルを取得して表示します。
getImageが動的にその時点でのボタンの画像を取得します
onActionがトグルボタンクリック時のアクション（関数）を指定しています。
getPressedがロード時に呼び出される関数です。

トグルボタンのロジック

トグルボタンのロジックはチェックボックスのロジックに加えて画像やラベルも切り替える必要がある点です。でないと、チェックボックスと変わらない。しかし、特にこの画像の切り替えなのですが、通常のプログラミングのように動的に切り替える事は出来ないので、変数を変更しリボンをリロードする事で実現しています。

'トグルボタンの状態を保存する
Public rbPressed As Boolean

'起動時にリボンの挙動を制御する
Public Sub ribbonman(ribbon As IRibbonUI)

　・・・・前略・・・・

　'トグルボタンを押した状態にする
　rbPressed = DLookup("モード", "setting", "ID=1")
    
End Sub

'トグルボタンのイメージ変更
Public Sub getButtonImage(ByVal control As IRibbonControl, ByRef image)
    If rbPressed = True Then
       Set image = LoadImage(CurrentProject.Path & "\images\sun.png")
    Else
       Set image = LoadImage(CurrentProject.Path & "\images\cloud.png")
    End If
End Sub

'トグルボタンのラベルを変更
Sub getLabel(control As IRibbonControl, ByRef returnedVal)
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("setting", dbOpenDynaset)

    If rbPressed = True Then
       returnedVal = "通常比較" & vbLf & "モード"
       
       'ボタンフラグを変更する
       With rs
         .FindFirst "ID=1"
         .Edit
         !モード = True
         .Update
       End With
    Else
       returnedVal = "当月同士比較" & vbLf & "モード"
       'ボタンフラグを変更する
       With rs
         .FindFirst "ID=1"
         .Edit
         !モード = False
         .Update
       End With
    End If
    
    db.Close
    Set db = Nothing
    Set rs = Nothing
End Sub

'トグルボタンの押されている状態を取得する
Public Sub getPressed(control As IRibbonControl, ByRef returnedVal)
  returnedVal = rbPressed
End Sub

'トグルボタンクリック時の処理
Sub toggleButton_onAction(control As IRibbonControl, pressed As Boolean)
　'現在の状態を変数に格納する
  rbPressed = pressed
  
  If rbPressed = True Then
    '押されてる状態
    MsgBox "通常比較モードで実行します"
  Else
    '押されていない状態
    MsgBox "当月同士比較モードで実行します"
  End If
  
　'リボンをリロードする
  Call UpdateTheLabel
  
End Sub

'対象のコントロールを再読み込み
Public Sub UpdateTheLabel()
    Set rbRibbon = myRibbon
    rbRibbon.InvalidateControl "modeman"
    'rbPressed = DLookup("モード", "setting", "ID=1")
End Sub

'トグルボタンの状態を保存する

Public rbPressed As Boolean

'起動時にリボンの挙動を制御する

Public Sub ribbonman(ribbon As IRibbonUI)

　・・・・前略・・・・

　'トグルボタンを押した状態にする

　rbPressed = DLookup("モード", "setting", "ID=1")

End Sub

'トグルボタンのイメージ変更

Public Sub getButtonImage(ByVal control As IRibbonControl, ByRef image)

If rbPressed = True Then

Set image = LoadImage(CurrentProject.Path & "\images\sun.png")

Else

Set image = LoadImage(CurrentProject.Path & "\images\cloud.png")

End If

End Sub

'トグルボタンのラベルを変更

Sub getLabel(control As IRibbonControl, ByRef returnedVal)

Dim db As DAO.Database

Dim rs As DAO.Recordset

Set db = CurrentDb()

Set rs = db.OpenRecordset("setting", dbOpenDynaset)

If rbPressed = True Then

returnedVal = "通常比較" & vbLf & "モード"

'ボタンフラグを変更する

With rs

.FindFirst "ID=1"

.Edit

!モード = True

.Update

End With

Else

returnedVal = "当月同士比較" & vbLf & "モード"

'ボタンフラグを変更する

With rs

.FindFirst "ID=1"

.Edit

!モード = False

.Update

End With

End If

db.Close

Set db = Nothing

Set rs = Nothing

End Sub

'トグルボタンの押されている状態を取得する

Public Sub getPressed(control As IRibbonControl, ByRef returnedVal)

returnedVal = rbPressed

End Sub

'トグルボタンクリック時の処理

Sub toggleButton_onAction(control As IRibbonControl, pressed As Boolean)

　'現在の状態を変数に格納する

rbPressed = pressed

If rbPressed = True Then

'押されてる状態

MsgBox "通常比較モードで実行します"

Else

'押されていない状態

MsgBox "当月同士比較モードで実行します"

End If

　'リボンをリロードする

Call UpdateTheLabel

End Sub

'対象のコントロールを再読み込み

Public Sub UpdateTheLabel()

Set rbRibbon = myRibbon

rbRibbon.InvalidateControl "modeman"

'rbPressed = DLookup("モード", "setting", "ID=1")

End Sub

実際にプログラム内でトグルボタンの状態を利用して条件分岐する場合には、rbPressed変数の状態を利用して分岐させます。
今回はフラグの状態によって、getButtonImageにて分岐し、LoadImageにて実際のpngファイルをロードしています。imagemsoも同様の処理で切り替える事が可能です。その場合はimagemsoの文字列だけを指定し、LoadImageは利用しません。
XML上のラベルでは、文字の位置調整で「」という文字を使って改行位置を決定していましたが、VBA内でそれを実現する場合、単にvbLfを入れるだけで同じ事が実現可能です。そして文字を切り替えるためにreturndValで返しています。
onActionにてラベルの変更、画像の変更、状態の変更を行い、UpdateTheLabelにてリボンをリロード（InvalidateControlメソッド）させて反映し直しています。
今回は状態の設定をiniファイルではなくsettingというテーブルを用意して、そこに状態を保存するようにしました。そのため、状態取得や読み書きはDlookupやDAOを使って読み書きしています。

アイコンに独自の画像を使う

Excelとは違い、Accessの場合にはimageMso以外の独自の画像を簡単に割り当てる事が出来ません。また、xlsmファイルとは違い画像ファイルをAccessファイル内に盛り込めないので、画像は同じフォルダ内にある画像を参照する形にする必要があります。

Accessに於けるボタンに独自のアイコンを割り当てる方法についてはこちらのサイトに詳しく解説がありますが、32bit版でなければ利用ができないコードになっています。しかし、海外のこちらのサイトにあるサンプルである「ExternalImages.zip」は64bit版にも対応したコードになっており、VBAにて外部イメージを使えるようにしています。

XML部分のコードもちょっと特殊。imagesで指定するのではなく、getImage属性にて指定し、画像ファイルを指定するのではなく、VBA内のサブプロシージャを参照するようになっています。ちょっと面倒ですね。シンプルな方法は以下の手順です。

以下のコードを標準モジュールを作って取り込んでおく
XML内のimageMso=部分を「getImage="myButton_getImage" 」としておく。＝以下は呼び出す関数名
呼び出す関数側は、対象の画像までのフルパスをsetするようにコードを記述する

Option Compare Database
Option Explicit

#If Win64 Then '================ WINDOWS 64 BITS ===================

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongLong, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongLong = 0) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As LongLong, BITMAP As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As LongLong) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongLong) As LongLong
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As Long

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PICTDESC
    cbSizeOfStruct As Long
    PicType As Long
    hImage As LongPtr
    xExt As Long
    yExt As Long
End Type

Private Type GdiplusStartupInput
    GdiplusVersion              As LongLong
    DebugEventCallback          As LongLong
    SuppressBackgroundThread    As LongLong
    SuppressExternalCodecs      As LongLong
End Type

Public Function LoadImage(ByVal strFName As String) As IPictureDisp
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As LongLong
Dim hGdiImage As LongLong
Dim hBitmap As LongLong

uGdiInput.GdiplusVersion = 1
    
    If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
        If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
            GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
            Set LoadImage = ConvertToIPicture(hBitmap)
            GdipDisposeImage hGdiImage
        End If
        GdiplusShutdown hGdiPlus
    End If

End Function

Public Function ConvertToIPicture(ByVal hPic As LongLong) As IPictureDisp

    Dim uPicInfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim IPic As IPictureDisp

    Const PICTYPE_BITMAP = 1

    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    
        With uPicInfo
            'If bIsIcon Then
                '.cbSizeOfStruct = 16
                '.PicType = 3    'PicType Icon
           ' Else
                .cbSizeOfStruct = Len(uPicInfo)
                .PicType = 1    'PicType Bitmap
            'End If
            .hImage = hPic 'hBmp
        End With

    OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

    Set ConvertToIPicture = IPic
End Function

#Else '=================== WINDOWS 32 BITS ========================
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, BITMAP As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type GUID
    Data1          As Long
    Data2          As Integer
    Data3          As Integer
    Data4(0 To 7)  As Byte
End Type

Private Type PICTDESC
    Size  As Long
    type  As Long
    hPic  As Long
    hpal  As Long
End Type

Private Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type

Public Function LoadImage(ByVal strFName As String) As IPictureDisp
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long

uGdiInput.GdiplusVersion = 1
    
    If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
        If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
            GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
            Set LoadImage = ConvertToIPicture(hBitmap)
            GdipDisposeImage hGdiImage
        End If
        GdiplusShutdown hGdiPlus
    End If

End Function

Public Function ConvertToIPicture(ByVal hPic As Long) As IPictureDisp

    Dim uPicInfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim IPic As IPicture

    Const PICTYPE_BITMAP = 1

    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .type = PICTYPE_BITMAP
        .hPic = hPic
        .hpal = 0
    End With

    OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

    Set ConvertToIPicture = IPic
End Function

#End If

’呼び出される関数（ボタンイメージ適用）
Sub myButton_getImage(control As IRibbonControl, ByRef image)
  Set image = LoadImage(CurrentProject.Path & "\images\star.png")
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

Option Compare Database

Option Explicit

#If Win64 Then '================ WINDOWS 64 BITS ===================

Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongLong, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongLong = 0) As Long

Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As LongLong, BITMAP As LongPtr) As Long

Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As LongPtr, hbmReturn As LongPtr, ByVal background As LongLong) As Long

Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long

Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongLong) As LongLong

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As Long

Public Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Private Type PICTDESC

cbSizeOfStruct As Long

PicType As Long

hImage As LongPtr

xExt As Long

yExt As Long

End Type

Private Type GdiplusStartupInput

GdiplusVersion As LongLong

DebugEventCallback As LongLong

SuppressBackgroundThread As LongLong

SuppressExternalCodecs As LongLong

End Type

Public Function LoadImage(ByVal strFName As String) As IPictureDisp

Dim uGdiInput As GdiplusStartupInput

Dim hGdiPlus As LongLong

Dim hGdiImage As LongLong

Dim hBitmap As LongLong

uGdiInput.GdiplusVersion = 1

If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then

If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then

GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0

Set LoadImage = ConvertToIPicture(hBitmap)

GdipDisposeImage hGdiImage

End If

GdiplusShutdown hGdiPlus

End If

End Function

Public Function ConvertToIPicture(ByVal hPic As LongLong) As IPictureDisp

Dim uPicInfo As PICTDESC

Dim IID_IDispatch As GUID

Dim IPic As IPictureDisp

Const PICTYPE_BITMAP = 1

With IID_IDispatch

.Data1 = &H7BF80980

.Data2 = &HBF32

.Data3 = &H101A

.Data4(0) = &H8B

.Data4(1) = &HBB

.Data4(2) = &H0

.Data4(3) = &HAA

.Data4(4) = &H0

.Data4(5) = &H30

.Data4(6) = &HC

.Data4(7) = &HAB

End With

With uPicInfo

'If bIsIcon Then

'.cbSizeOfStruct = 16

'.PicType = 3 'PicType Icon

' Else

.cbSizeOfStruct = Len(uPicInfo)

.PicType = 1 'PicType Bitmap

'End If

.hImage = hPic 'hBmp

End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

Set ConvertToIPicture = IPic

End Function

#Else '=================== WINDOWS 32 BITS ========================

Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long

Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal FileName As Long, BITMAP As Long) As Long

Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long

Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long

Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

Private Type PICTDESC

Size As Long

type As Long

hPic As Long

hpal As Long

End Type

Private Type GdiplusStartupInput

GdiplusVersion As Long

DebugEventCallback As Long

SuppressBackgroundThread As Long

SuppressExternalCodecs As Long

End Type

Public Function LoadImage(ByVal strFName As String) As IPictureDisp

Dim uGdiInput As GdiplusStartupInput

Dim hGdiPlus As Long

Dim hGdiImage As Long

Dim hBitmap As Long

uGdiInput.GdiplusVersion = 1

If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then

If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then

GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0

Set LoadImage = ConvertToIPicture(hBitmap)

GdipDisposeImage hGdiImage

End If

GdiplusShutdown hGdiPlus

End If

End Function

Public Function ConvertToIPicture(ByVal hPic As Long) As IPictureDisp

Dim uPicInfo As PICTDESC

Dim IID_IDispatch As GUID

Dim IPic As IPicture

Const PICTYPE_BITMAP = 1

With IID_IDispatch

.Data1 = &H7BF80980

.Data2 = &HBF32

.Data3 = &H101A

.Data4(0) = &H8B

.Data4(1) = &HBB

.Data4(2) = &H0

.Data4(3) = &HAA

.Data4(4) = &H0

.Data4(5) = &H30

.Data4(6) = &HC

.Data4(7) = &HAB

End With

With uPicInfo

.Size = Len(uPicInfo)

.type = PICTYPE_BITMAP

.hPic = hPic

.hpal = 0

End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

Set ConvertToIPicture = IPic

End Function

#End If

’呼び出される関数（ボタンイメージ適用）

Sub myButton_getImage(control As IRibbonControl, ByRef image)

Set image = LoadImage(CurrentProject.Path & "\images\star.png")

End Sub

図：オリジナルの画像を適用できた。

図：Accessでも独自のアイコンは使えるよ

ExcelとAccessに独自のリボンを追加する

今回使用するファイル

Excelにリボンを追加する

Custom UI Editor Tool

起動時初期化のコード

リボンを作成する

サンプルコード

imageMsoについて

主に使うパーツ

Accessにリボンを追加する

Usysribbonsテーブルを作る

起動時初期化のコード

リボンを作成する

起動時に初期化する

ボタンの実行に関数を割り当て

実行用のコード

ボタンの幅などのTips

チェックボックスを利用する

リボンXMLについて

チェックボックスのロジック

トグルボタンを利用する

トグルボタンのXML

トグルボタンのロジック

アイコンに独自の画像を使う

関連リンク

コメントを残すコメントをキャンセル

PC版Google Driveを使う上での注意点

たくさんある画像を一括変換するならirfanview

今回使用するファイル

Excelにリボンを追加する

Custom UI Editor Tool

起動時初期化のコード

リボンを作成する

サンプルコード

imageMsoについて

主に使うパーツ

Accessにリボンを追加する

Usysribbonsテーブルを作る

起動時初期化のコード

リボンを作成する

起動時に初期化する

ボタンの実行に関数を割り当て

実行用のコード

ボタンの幅などのTips

チェックボックスを利用する

リボンXMLについて

チェックボックスのロジック

トグルボタンを利用する

トグルボタンのXML

トグルボタンのロジック

アイコンに独自の画像を使う

関連リンク

コメントを残す コメントをキャンセル

PC版Google Driveを使う上での注意点

たくさんある画像を一括変換するならirfanview

コメントを残すコメントをキャンセル