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

Application


【ファイル名】Application.xlsm
【バージョン】Ver 1.0.4.2
【作成日】2015年02月16日
【更新日】2019年03月17日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】Application.zip
【説明】Applicationのサンプルです。

メニュー

「現在の時間」ボタンの処理だけ元に戻せます。

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="Sample" insertBeforeMso="TabHome" keytip="SAM">
        <group id="Group1" label="Applicaion">
          <box id="Box1" boxStyle="horizontal">
 <!-- ■■■ プロパティ -->
            <menu id="PropertyMenu" label="プロパティ(&P)" itemSize="normal" imageMso="PropertySheet" size="normal" keytip="P">
              <button id="ActiveCellButton" label="ActiveCell.Address(&C)" supertip="アクティブセルのアドレスを表示します。"  imageMso="CellDiagonalsGallery" onAction="onAction" tag="ActiveCell.Address" />
              <button id="ActiveSheetButton" label="ActiveSheet.Name(&S)" supertip="アクティブシートの名前を表示します。"  imageMso="SheetInsert" onAction="onAction" tag="ActiveSheet.Name" />
              <button id="ActiveWindowButton" label="ActiveWindow.Caption(&W)" supertip="アクティブ ウィンドウのキャプションを表示します。"  imageMso="WindowUnhide" onAction="onAction" tag="ActiveWindow.Caption" />
              <button id="ActiveWorkbookFullNameButton" label="ActiveWorkbook.FullName(&F)" supertip="アクティブワークブックのフル名を表示します。"  imageMso="BuildingBlocksOrganizer" onAction="onAction" tag="ActiveWorkbook.FullName" />
              <button id="CaptionButton" label="Application.Caption(&C)" supertip="キャプションを表示します。"  imageMso="ExcelSpreadsheetInsert" onAction="onAction" tag="Application.Caption" />
              <button id="CursorButton" label="Cursor(&C)" supertip="一時的にカーソルを変更します。"  imageMso="Pointer" onAction="onAction" tag="Cursor" />
              <button id="DefaultFilePathButton" label="DefaultFilePath(&D)" supertip="既定のファイルの場所を表示します。"  imageMso="Folder" onAction="onAction" tag="DefaultFilePath" />
              <button id="DialogsButton" label="Dialogs(&D)" supertip="ファイルを開くダイアログを表示します。"  imageMso="FileOpen" onAction="onAction" tag="Dialogs" />
              <checkBox id="DisplayAlertsButton" label="DisplayAlerts(&A)" supertip="チェックを外すとシートを削除するときにメッセージを表示しません。" getPressed="getPressed" onAction="onCheckBoxAction" />
              <checkBox id="DisplayClipboardWindowButton" label="DisplayClipboardWindow(&C)" supertip="[Office クリップボード]作業ウィンドウの表示・非表示を切り換えます。" getPressed="getPressed" onAction="onCheckBoxAction" />
              <button id="LibraryPathButton" label="LibraryPath(&L)" supertip="ライブラリーのフォルダ名を表示します。" imageMso="Folder" onAction="onAction" tag="LibraryPath" />
              <button id="PathButton" label="Path(&P)" supertip="エクセル(EXCEL.EXE)のあるパスを表示します。"  imageMso="Folder" onAction="onAction" tag="Path" />
              <button id="ActivePrinterButton" label="ActivePrinter(&P)" supertip="現在のプリンターの名前を表示します。"  imageMso="PrintAttach" onAction="onAction" tag="ActivePrinter" />
              <button id="SelectionButton" label="Selection(&S)" supertip="Selectionのタイプ名を表示します。"  imageMso="SelectCurrentRegion" onAction="onAction" tag="Selection" />
              <button id="StartupPathButton" label="StartupPath(&S)" supertip="エクセルのスタートアップフォルダ名を表示します。"  imageMso="Folder" onAction="onAction" tag="StartupPath" />
              <button id="StatusBarButton" label="StatusBar(&S)" supertip="ステータスバーに文字列を表示します。"  imageMso="HappyFace" onAction="onAction" tag="StatusBar" />
              <button id="TemplatesPathButton" label="TemplatesPath(&T)" supertip="テンプレートのフォルダ名を表示します。"  imageMso="Folder" onAction="onAction" tag="TemplatesPath" />
              <button id="ThisWorkbookButton" label="ThisWorkbook.FullName(&W)" supertip="このワークブックの名前を表示します。"  imageMso="BuildingBlocksOrganizer" onAction="onAction" tag="ThisWorkbook.FullName" />
              <button id="UserLibraryPathButton" label="UserLibraryPath(&A)" supertip="アドインのフォルダ名を表示します。"  imageMso="Folder" onAction="onAction" tag="UserLibraryPath" />
              <button id="UserNameButton" label="UserName(&U)" supertip="ユーザー名を表示します。"  imageMso="UseAccountOnAnotherComputer" onAction="onAction" tag="UserName" />
              <button id="VersionButton" label="Version(&V)" supertip="バージョンを表示します。"  imageMso="Info" onAction="onAction" tag="Version" />
              <button id="VisibleButton" label="Visible(&V)" supertip="エクセルを一時的に非表示にします。"  imageMso="WindowHide" onAction="onAction" tag="Visible" />
            </menu>
 <!-- ■■■ メソッド -->
            <menu id="MethodMenu" label="メソッド(&M)" itemSize="normal" imageMso="Club" size="normal" keytip="M">
              <button id="GetOpenFilenameButton" label="GetOpenFilename(&O)" supertip="ファイルを開くダイアログを表示します。"  imageMso="FileOpen" onAction="onAction" tag="GetOpenFilename" />
              <button id="GetSaveAsFilenameButton" label="GetSaveAsFilename(&S)" supertip="名前を付けて保存のダイアログを表示します。"  imageMso="FileSaveAs" onAction="onAction" tag="GetSaveAsFilename" />
              <button id="GotoButton" label="Goto(&G)" supertip="A1のセルに移動します。"  imageMso="GoTo" onAction="onAction" tag="Goto" />
              <button id="InputBoxButton" label="InputBox(&I)" supertip="セルを選択するためのダイアログを表示します。"  imageMso="XDPlainTextField" onAction="onAction" tag="InputBox" />
              <button id="OnKeyButton" label="OnKey(&K)    Ctrl+M" supertip="このメニューを実行しないで、直接Ctrlキーを押しながらMキーを押してください。"  imageMso="M" onAction="onAction" tag="OnKey" />
              <button id="SendKeysButton" label="SendKeys(&S)" supertip="ファイルを開くダイアログを表示します。"  imageMso="FileOpen" onAction="onAction" tag="SendKeys" />
              <menuSeparator id="MethodMenuSeparator1" />
              <button id="QuitButton" label="Quit(&Q)" supertip="エクセルを終了します。"  imageMso="QuickSearchCancel" onAction="onAction" tag="Quit" />
            </menu>
          </box>
 <!-- ■■■ 標準のコントロールと元に戻す処理のための処理 -->
          <separator id="Separator1" />
          <gallery idMso="Undo" />
          <gallery idMso="Redo" />
          <button idMso="Repeat" />
          <button id="TimeButton" label="現在の時間(&T)" supertip="アクティブセルに現在の時間を代入します。&#x0D;この処理は元に戻せます。"  imageMso="StartAfterPrevious" onAction="onAction" tag="現在の時間" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

このページの上

ApplicationModule
Option Explicit
Private rbRibbonUI As IRibbonUI   ' リボン
Private IsDisplayAlerts As Boolean ' シートを削除するときにメッセージの表示/非表示
Private IsDisplayClipboardWindow As Boolean ' クリップボード作業ウィンドウの表示/非表示
Private ControlId As String ' control.ID
Private ControlTag As String ' control.Tag
Private ActivecellAddress As Range ' Activecell
Private ActivecellValue As Variant ' Activecell.Value

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  IsDisplayAlerts = Application.DisplayAlerts
  IsDisplayClipboardWindow = Application.DisplayClipboardWindow
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub getPressed(control As IRibbonControl, ByRef returnedVal) ' チェックボックスにチェックを設定する
  Select Case control.ID
    Case "DisplayAlertsButton"
      returnedVal = Application.DisplayAlerts
    Case "DisplayClipboardWindowButton"
      returnedVal = Application.DisplayClipboardWindow
  End Select
End Sub

Sub onCheckBoxAction(control As IRibbonControl, pressed As Boolean) ' チェックボックスのクリック処理
  Select Case control.ID
    Case "DisplayAlertsButton"
      Application.DisplayAlerts = pressed
      IsDisplayAlerts = pressed
    Case "DisplayClipboardWindowButton"
      Application.DisplayClipboardWindow = pressed '
      IsDisplayClipboardWindow = pressed
  End Select
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  ControlId = control.ID
  ControlTag = control.Tag
  Application.Run ThisWorkbook.Name & "!MainAction"
End Sub

Sub MainAction()
  Dim s As String
  Dim Rng As Range

  On Error GoTo ErrorHandler ' エラー処理ルーチン
  Select Case ControlId
'---< プロパティ >--------------------------------------------------------------------------------------------------------
    Case "ActiveCellButton"
      If Application.ActiveCell Is Nothing Then Exit Sub
      MsgBox Prompt:=Application.ActiveCell.Address, Buttons:=vbInformation, Title:="ActiveCell"
    Case "ActiveSheetButton"
      If Application.ActiveSheet Is Nothing Then Exit Sub
      MsgBox Prompt:=Application.ActiveSheet.Name, Buttons:=vbInformation, Title:="ActiveSheet.Name"
    Case "ActiveWindowButton"
      If Application.ActiveWindow Is Nothing Then Exit Sub
      MsgBox Prompt:=Application.ActiveWindow.Caption, Buttons:=vbInformation, Title:="ActiveWindow.Caption"
    Case "ActiveWorkbookFullNameButton"
      If Application.ActiveWorkbook Is Nothing Then Exit Sub
      MsgBox Prompt:=Application.ActiveWorkbook.FullName, Buttons:=vbInformation, Title:="ActiveWorkbook.FullName"
    Case "CaptionButton"
      MsgBox Prompt:=Application.Caption, Buttons:=vbInformation, Title:="Caption"
    Case "CursorButton"
      Application.Cursor = xlWait
      Application.Wait Now + TimeValue("00:00:02")
      Application.Cursor = xlIBeam
      Application.Wait Now + TimeValue("00:00:02")
      Application.Cursor = xlNorthwestArrow
      Application.Wait Now + TimeValue("00:00:02")
      Application.Cursor = xlDefault
    Case "DefaultFilePathButton"
      MsgBox Prompt:=Application.DefaultFilePath, Buttons:=vbInformation, Title:="DefaultFilePath"
    Case "DialogsButton"
      Application.Dialogs(xlDialogOpen).Show
    Case "LibraryPathButton"
      MsgBox Prompt:=Application.LibraryPath, Buttons:=vbInformation, Title:="LibraryPath"
    Case "PathButton"
      MsgBox Prompt:=Application.Path, Buttons:=vbInformation, Title:="Path"
    Case "ActivePrinterButton"
      MsgBox Prompt:=Application.ActivePrinter, Buttons:=vbInformation, Title:="ActivePrinter"
    Case "SelectionButton"
      MsgBox Prompt:=TypeName(Application.Selection), Buttons:=vbInformation, Title:="Selection"
    Case "StartupPathButton"
      MsgBox Prompt:=Application.StartupPath, Buttons:=vbInformation, Title:="StartupPath"
    Case "StatusBarButton"
      Call LongTimeProc
    Case "TemplatesPathButton"
      MsgBox Prompt:=Application.TemplatesPath, Buttons:=vbInformation, Title:="TemplatesPath"
    Case "ThisWorkbookButton"
      MsgBox Prompt:=Application.ThisWorkbook.FullName, Buttons:=vbInformation, Title:="ThisWorkbook.FullName"
    Case "UserLibraryPathButton"
      MsgBox Prompt:=Application.UserLibraryPath, Buttons:=vbInformation, Title:="UserLibraryPath"
    Case "UserNameButton"
      MsgBox Prompt:=Application.UserName, Buttons:=vbInformation, Title:="UserName"
    Case "VersionButton"
      MsgBox Prompt:=Application.Version, Buttons:=vbInformation, Title:="Version"
    Case "VisibleButton"
      Application.Visible = False
      Application.Wait Now + TimeValue("00:00:02")
      Application.Visible = True
'---< メソッド >--------------------------------------------------------------------------------------------------------
    Case "GetOpenFilenameButton"
      s = Application.GetOpenFilename(FileFilter:="エクセルファイル(*.xl*),*.xl*,テキストファイル(*.txt), *.txt,すべてのファイル(*.*),*.*", FilterIndex:=1, Title:="ファイルの参照", ButtonText:="参照", MultiSelect:=False)
      If s = "False" Then Exit Sub
      MsgBox Prompt:=s, Buttons:=vbInformation, Title:="GetOpenFilename"
    Case "GetSaveAsFilenameButton"
      s = Application.GetSaveAsFilename(InitialFileName:="InitialFilenameBook.xlsx", FileFilter:="エクセルファイル(*.xl*),*.xl*,テキストファイル(*.txt), *.txt,すべてのファイル(*.*),*.*", FilterIndex:=1, Title:="名前を付けて保存", ButtonText:="保存")
      If s = "False" Then Exit Sub
      MsgBox Prompt:=s, Buttons:=vbInformation, Title:="GetSaveAsFilename"
    Case "GotoButton"
      If Application.ActiveCell Is Nothing Then Exit Sub
      Application.GoTo Reference:=Application.ActiveSheet.Range("A1"), Scroll:=True
    Case "InputBoxButton"
      Set Rng = Application.InputBox(Prompt:="セルを選択してください。", Title:="セルの選択", Default:="A1", Type:=8)
      If Rng Is Nothing Then Exit Sub
      MsgBox Prompt:=Rng.Address, Buttons:=vbInformation, Title:="InputBox"
    Case "OnKeyButton"
      MsgBox Prompt:="Ctrlキーを押しながらMキーを押してください。", Buttons:=vbInformation, Title:="OnKey"
    Case "SendKeysButton"
      Application.SendKeys Keys:="^o", Wait:=False
    Case "QuitButton"
      Application.Quit
    Case "TimeButton" ' アクティブセルに現在の時間を代入します。この処理は元に戻せます。
      If Application.ActiveCell Is Nothing Then Exit Sub
      ActivecellValue = Application.ActiveCell.Value ' 元に戻すためにValueを記憶する
      Set ActivecellAddress = ActiveCell ' 元に戻すために記憶する
      Application.ActiveCell.Value = Time
      Application.OnUndo ControlTag, ThisWorkbook.Name & "!myOnUndo" ' 元に戻すに登録
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=ControlId & "の処理がありません!", Buttons:=vbCritical, Title:="エラー"
      Exit Sub
  End Select

  Application.OnRepeat "繰り返し " & ControlTag, ThisWorkbook.Name & "!myOnRepeat" ' 繰り返しに登録
  Exit Sub

ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical, Title:="エラー"
End Sub
' 繰り返し処理
Private Sub myOnRepeat()
  Call MainAction
End Sub
' 元に戻す処理
Private Sub myOnUndo()
  Application.GoTo Reference:=ActivecellAddress, Scroll:=False
  If Not Application.ActiveCell Is Nothing Then Application.ActiveCell.Value = ActivecellValue
End Sub
' Ctrl+Mのショートカットキーの処理 ThisWorkbookのWorkbook_OpenイベントでApplication.OnKeyで設定してます。
Public Sub Ctrl_M()
  MsgBox Prompt:="Ctrl + M", Buttons:=vbInformation, Title:="OnKey"
End Sub
' 長い時間がかかる処理
Sub LongTimeProc()
  Dim i As Long
  Dim tmpCalculation As XlCalculation ' 計算方法のモード
  Dim Ret As VbMsgBoxResult ' MsgBoxの返値
  Dim IsDisplayPageBreaks As Boolean  ' 改ページの有効・無効

  Err.Clear ' エラーをクリアーします。
  On Error GoTo ErrorHandle ' ◆ エラー処理ルーチンを有効にします。
  Application.EnableEvents = False ' イベントを無効にします。
  If Not Application.ActiveCell Is Nothing Then
    tmpCalculation = Application.Calculation ' 計算方法のモードを保存
    Application.Calculation = xlCalculationManual ' 計算方法のモードを手動にし、計算しない
    IsDisplayPageBreaks = ActiveSheet.DisplayPageBreaks ' 改ページの有効・無効を保存します。
    ActiveSheet.DisplayPageBreaks = False ' 改ページを無効にします。
  End If
  Application.EnableCancelKey = xlErrorHandler ' ◆ Esc キーを押すとエラーにします。
  Application.StatusBar = "実行中です。しばらくお待ちください..." ' ステータスバーにメッセージを表示
  Application.DisplayStatusBar = True ' ステータスバーを表示
  Application.Cursor = xlWait ' マウスカーソルを砂時計
  Application.ScreenUpdating = False '画面の更新を停止して、ちらつきを防止(ステータスバーのメッセージは更新できます)

  For i = 1 To 5 ' 長い時間がかかる処理
    Application.Wait Now + TimeSerial(0, 0, 1) ' 1秒待ちます。
    Application.StatusBar = String$(i * 2, "■") ' Application.ScreenUpdating = Falseでも、StatusBarの表示は変更されます。
    DoEvents ' オペレーティング システムによって処理できるようにする。
  Next i

ErrorHandle: ' ◆ 元に戻す処理 (エラーや、[ESC]キーが押された場合のため)
  If Err.Number > 0 Then ' エラー処理
    Ret = MsgBox(Prompt:=Err.Description & vbCrLf & vbCrLf & "処理を続けますか?", Buttons:=vbExclamation + vbAbortRetryIgnore, Title:="エラー")
    Err.Clear ' エラーをクリアーします。
    If Ret = vbRetry Then Resume ' 再試行
    If Ret = vbIgnore Then Resume Next ' 無視
    ' 中止の場合は下の行の処理へ
  End If
' 元の設定に戻します。
  Application.EnableEvents = True ' イベントを有効にします。
  If Not Application.ActiveCell Is Nothing Then
    Application.Calculation = tmpCalculation ' 計算方法のモードを元に戻す
    ActiveSheet.DisplayPageBreaks = IsDisplayPageBreaks ' 改ページを元に戻します。
  End If
  Application.StatusBar = "" ' ステータスバーをを元に戻す
  Application.Cursor = xlDefault ' マウスカーソルを省略値に戻す
  Application.EnableCancelKey = xlInterrupt ' デバッグ、終了などを行えるように、実行中のプロシージャを停止
  Application.ScreenUpdating = True '画面の更新をする
End Sub

このページの上

ThisWorkbook
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Application.OnKey Key:="^m"
End Sub

Private Sub Workbook_Open()
  On Error Resume Next
  Application.OnKey Key:="^m", Procedure:="Ctrl_M"
  On Error GoTo 0
End Sub
最初にダウンロードした時はWorkbook_Openイベントをセキュリティのため実行されません。

このページの上