[XL] マウスカーソルの形を変更する方法

詳細

VBA のサブルーチンを実行する際に処理に時間が掛かる場合など、マウスカーソルの形を変更したい時があります。これを実現するには Microsoft(R) Windows (TM) (以下 Windows) が標準で提供している API (Application Programing Interface) を使用しなければなりません。
Windows では "LoadCursor"、"SetCursor"、"DestroyCursor" という API を使用してマウスカーソルの変更を行っています。VBA でもこれらの API を Declare ステートメントで宣言した後に適切な引数を指定して関数呼び出しを行うことにより実現が可能です。
なお、各 Windows API についての詳細は Windows API のヘルプを参照してください。

サンプル モジュール 1

カーソルの変更を API を使用して行うプロシージャ

"SetWait True" を実行するとマウスカーソルを指定した形状に変更し、"SetWait False" を実行すると、変更を行う時点で使用していたマウスカーソルの形状に戻します。このプロシージャは、時間の掛かる作業の始めと終わりに使用してください。必ず "SetWait True" と "SetWait False" を一対にして使用するようにしてください。

  'API の Declare 宣言
  Private Declare Function LoadCursor Lib "USER" (ByVal hInstance As _
  Integer, ByVal lpCursorName As Any) As Integer
  Private Declare Function DestroyCursor Lib "USER" (ByVal hCursor As _
  Integer) As Integer
  Private Declare Function SetCursor Lib "USER" (ByVal hCursor As _
  Integer) As Integer
  '標準で用意されているマウスカーソルの定数の定義 (それぞれの形状については、
  '実際に試してご確認ください)
  Private Const IDC_ARROW = 32512&
  Private Const IDC_IBEAM = 32513&
  Private Const IDC_WAIT = 32514&
  Private Const IDC_CROSS = 32515&
  Private Const IDC_UPARROW = 32516&
  Private Const IDC_SIZE = 32640&
  Private Const IDC_ICON = 32641&
  Private Const IDC_SIZENWSE = 32642&
  Private Const IDC_SIZENESW = 32643&
  Private Const IDC_SIZEWE = 32644&
  Private Const IDC_SIZENS = 32645&
  Sub SetWait(fSetWaitCursor As Boolean)
      Static oldcursor%, fWaitCursorSet As Boolean
      If fSetWaitCursor Then
          '指定カーソルの読み込み及び設定
          oldcursor% = SetCursor(LoadCursor(0, IDC_WAIT))
          fWaitCursorSet = True
      ElseIf Not fSetWaitCursor And fWaitCursorSet Then
          '元のカーソルに復元
          SetCursor oldcursor%
          fWaitCursorSet = False
      End If
  End Sub

サンプル モジュール 2

SetWait プロシージャの動作確認を行うためのプロシージャ

マウスカーソルを砂時計型カーソルに変更し、ループ処理を行った後、元のマウスカーソルの形状に戻します。カーソルを変更している時間は、For ステートメントの繰り返し回数を変更して調整することができます。

  Sub CursorChangeTest()
      Dim i As Double
      Dim a As String
      'カーソルの設定
      SetWait True
      'ループ処理
      For i = 1 To 50000 Step 1
          a = "a"
      Next i
      'カーソルの再設定
      SetWait False
  End Sub