[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