HOME > エクセルVBA > サンプル > ApplicationEvent

ApplicationEvent


【ファイル名】ApplicationEvent.xlam
【バージョン】Ver 1.0.2.1
【作成日】2015年03月04日
【更新日】2019年03月30日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ApplicationEvent.zip(リボンのコントロールの有効・無効)
【ダウンロード】Application_Event_Debug_Print.zip Applicationのイベントの確認用(Debug.Print)
【ダウンロード】Application_Event_MsgBox.zip Applicationのイベントの確認用(MsgBox)
【説明】Applicationのイベントのサンプルです。
【注意】セルからオブジェクトを選択した場合は、SheetSelectionChangeイベントは発生しません。

リボンの[サンプル]タブ

ApplicationEvent.xlam・・・リボンのコントロールの有効・無効を切り替えます。Windows APIのSetTimerで割り込み処理をします。
Application_Event_Debug_Print.xlam・・・Applicationのイベントが発生するとDebug.Printでイミディエイト ウィンドウに出力します。
Application_Event_MsgBox.xlam・・・Applicationのイベントが発生するとMsgBoxで表示します。(メッセージのボタンを実行しなければいけないので面倒です)

customUI.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="ApplicationEvent.xlam!onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="SAM">
        <group id="Group1" label="ApplicationEvent">
          <box id="Box1" boxStyle="horizontal">
            <button id="CloseButton" label="閉じる(&W)" supertip="ブックを閉じます。"  imageMso="FileClose" onAction="ApplicationEvent.xlam!onAction"  getEnabled="ApplicationEvent.xlam!getEnabled" />
            <button id="ActiveCellButton" label="ActiveCell(&S)" supertip="アクティブセルのアドレスを表示します。"  imageMso="Heart" onAction="ApplicationEvent.xlam!onAction" getEnabled="ApplicationEvent.xlam!getEnabled" />
            <button id="SelectionRangeButton" label="Selection.Range(&S)" supertip="セルの選択範囲のアドレスを表示します。"  imageMso="HappyFace" onAction="ApplicationEvent.xlam!onAction" getEnabled="ApplicationEvent.xlam!getEnabled" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

このページの上

MainModule
Option Explicit

#If Win64 Then ' Office 64 bit
  ' https://msdn.microsoft.com/ja-jp/library/cc411200.aspx
  Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
  ' https://msdn.microsoft.com/ja-jp/library/cc410876.aspx
  Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32.dll" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
#End If

Dim AppCls As New ApplicationClass ' アプリケーションのイベントのクラス
Public rbCloseButton_Enabled As Boolean ' ボタンの有効・無効
Public ActiveCellButton_Enabled As Boolean ' ボタンの有効・無効
Public SelectionRangeButton_Enabled As Boolean ' ボタンの有効・無効

#If Win64 Then ' Office 64 bit
  Private TimerID As LongPtr ' タイマーのID
#Else
  Private TimerID As Long ' タイマーのID
#End If

Private rbRibbon As IRibbonUI ' リボン
' 初期処理
Public Sub Init_App()
  Set AppCls.App = Application
  TimerID = SetTimer(0, 0, 500, AddressOf OnIdle) ' タイマーのセット
'  Application.OnTime Now + TimeValue("00:00:01"), Procedure:="OnIdle" ' 1秒では遅い
End Sub
' 終了処理
Public Sub Destroy()
  KillTimer 0, TimerID ' タイマーの削除
'  Application.OnTime Now + TimeValue("00:00:01"), Procedure:="OnIdle", Schedule:=False ' 停止
End Sub
' タイマーのイベント処理(ボタンの有効・無効の切り替え)
Sub OnIdle()
' 【注意】セルからオブジェクトを選択した場合は、SheetSelectionChangeイベントは発生しません。
  Dim sr As Boolean
  
  If TypeName(Application.Selection) = "Range" Then
    sr = True
  Else
    sr = False
  End If
  If SelectionRangeButton_Enabled <> sr Then ' 画面のチラつきを防止すために変更した場合のみ設定します。
    SelectionRangeButton_Enabled = sr
    rbRibbon.Invalidate ' リボンを更新
  End If
'  Application.OnTime Now + TimeValue("00:00:01"), Procedure:="OnIdle" ' 1秒では遅い
End Sub
' リボンの初期処理
Sub onLoad(ribbon As IRibbonUI)
  Set rbRibbon = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbCloseButton_Enabled = Application.Workbooks.Count > 1
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
  rbRibbon.Invalidate ' リボンを更新
End Sub
' リボンのコントロールの有効・無効の設定
Sub getEnabled(control As IRibbonControl, ByRef returnedVal)
  Select Case control.ID
    Case Is = "CloseButton"
      returnedVal = rbCloseButton_Enabled
    Case Is = "ActiveCellButton"
      returnedVal = ActiveCellButton_Enabled
    Case Is = "SelectionRangeButton"
      returnedVal = SelectionRangeButton_Enabled
  End Select
  rbRibbon.Invalidate ' リボンを更新
End Sub
' リボンのコントロールのコマンド処理
Sub onAction(control As IRibbonControl)
  Select Case control.ID
    Case Is = "CloseButton"
      ActiveWorkbook.Close
    Case Is = "ActiveCellButton"
      If Application.ActiveCell Is Nothing Then Exit Sub
      MsgBox Prompt:="ActiveCell = " & Application.ActiveCell.Address, Buttons:=vbInformation, Title:="ActiveCell.Address"
'      MsgBox Prompt:="RangeSelection = " & ActiveWindow.RangeSelection.Address
    Case Is = "SelectionRangeButton"
      If TypeName(Application.Selection) <> "Range" Then Exit Sub
      MsgBox Prompt:="Selection = " & Application.Selection.Address, Buttons:=vbInformation, Title:="Selection.Address"
  End Select
End Sub
 ' リボンを更新
Sub Refresh_Ribbon()
  rbRibbon.Invalidate ' リボンを更新
End Sub

このページの上

ApplicationClass
Option Explicit

Public WithEvents App As Application

' Workbook
Private Sub App_NewWorkbook(ByVal Wb As Workbook)
  rbCloseButton_Enabled = True
End Sub

Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
  rbCloseButton_Enabled = True
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_WorkbookOpen(ByVal Wb As Workbook)
  rbCloseButton_Enabled = True
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
  rbCloseButton_Enabled = Application.Workbooks.Count > 1
  If Application.Workbooks.Count < 2 Then ActiveCellButton_Enabled = False
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

' Window
Private Sub App_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

' Sheet
Private Sub App_SheetActivate(ByVal Sh As Object)
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_WorkbookNewSheet(ByVal Wb As Workbook, ByVal Sh As Object)
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
' 【注意】オブジェクトを選択した場合は、このイベントは発生しません。
  If ActiveCellButton_Enabled <> Not Application.ActiveCell Is Nothing Then
    ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  End If
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_SheetChange(ByVal Sh As Object, ByVal Target As Range)
  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
  SelectionRangeButton_Enabled = TypeName(Application.Selection) = "Range"
End Sub

Private Sub App_SheetDeactivate(ByVal Sh As Object)
'  ActiveCellButton_Enabled = Not Application.ActiveCell Is Nothing
End Sub

このページの上