モーダルフォーム上でアクティブセルを移動させるマウスパッド機能を
提供するサブルーチンです。
Call ktCellMovePad ( Action, Now_X, Now_Y, Now_Shift,
Before_X, Before_Y, MousePad, ActRng,
[Book名], [Sheet名] )
Action ‥‥‥ Boolean 型 Now_X ‥‥‥ Single 型 Now_Y ‥‥‥ Single 型 Now_Shift ‥‥‥ Integer 型 Before_X ‥‥‥ Single 型 （ByRef ） Before_Y ‥‥‥ Single 型 (ByRef ) MousePad ‥‥‥ MSForms.Label 型 （ByRef ） ActRng ‥‥‥ Range 型 （ByRef ） Book名 ‥‥‥ String 型 （省略可､省略時="" ） Sheet名 ‥‥‥ String 型 （省略可､省略時="" ）
※ 実際には､使用例そのままにコピーして利用して下さい。
Action ‥‥‥ UserForm_Initialize および UserForm_MouseMove では[False ]
MousePad に指定するラベルの MouseMove では[True ]
Now_X
/ Now_Y‥‥‥ UserForm_Initialize および UserForm_MouseMove では[ 0 ]
MousePad に指定するラベルの MouseMove では、
MouseMoveイベントで得られる[ X ][ Y ]を指定
Now_Shift ‥‥‥ UserForm_Initialize および UserForm_MouseMove では[ 0 ]
MousePad に指定するラベルの MouseMove では
MouseMoveイベントで得られる[ Shift ]を指定
Before_X
/ Before_Y‥‥‥ モジュール宣言セクションにて[Private ]で定義したSingle 型変数を指定
MousePad ‥‥‥ マウスパッド用に用意した「ラベル」を指定
このラベルは背景色[白]で用意して下さい。幅/高さは任意です。
ActRng ‥‥‥ Range 型変数を指定
Action=False の場合､常に[Nothing ]が返ります。
Action=True で Book名/Sheet名を指定しない場合
ActiveCell のRange オブジェクトが返ります。
Action=True で Book名/Sheet名を指定した場合
Book名/Sheet名が存在すれば､
そのシートがアクティブになって､ActiveCell のRange オブジェクト
が返ります。
Book名/Sheet名が存在しなければ､
[Nothing ]が返ります。
マウスパッドを複数用意して複数のセル位置を指定する場合は、モジュール宣言セクションにて[Private ]で定義したRange 型変数を用意し、この[ActRng]の内容を保存していくようにします（例：暦シートの作成）。
Book名
/ Sheet名‥‥‥ フォームにBook/Sheet の選択機能も持たせる場合に､そのBook名/Sheet名を指定します。
マウスパッド用ラベルに入った瞬間（Action=Trueで Call 中）に､Book名/Sheet名の存在チェックが行なわれます。
存在しない場合､[ActRng = Nothing ]を返し､マウスパッド用ラベルの背景を薄赤にします。存在すれば､[ActRng ]にActiveCell を返し､背景は白または薄黄（Shift 押下中）になります。
Book/Sheet の切り換えが無く､現在のActiveSheetのみを対象とする場合は省略します。
[Action = False ]の場合は省略して構いません。
モードレスフォームではフォーム表示中に自由にセルを選択してアクティブセルを変えられますが､
モーダルフォーム表示中にはシートに触れません。このサブルーチンは､UserForm上にラベルを用
意し､
そのラベル内で[Shift ]を押しながらマウスを動かした時に､
マウスの動いたのと同じ方向へアクティブセルを移動
させる機能を提供します。
現在のアクティブシートのみ対象とする例 ： 祝日一覧作成 , カレンダーマーク描画
ブック/シートの選択機能を持たせる例 ： 休日マップ作成
複数のセル位置取得（ブック/シート選択付き）の例： 暦シートの作成
UserFormにラベル「 lblMousePad 」を用意し､UserFormモジュールに下記コードを
そのまま貼り付けて下さい。
'----------- ひとつのセル指定（Book/Sheet 切り換えが無い場合） ---------------
Private Before_X As Single
Private Before_Y As Single
Private rngActCell As Range
Private Sub UserForm_Initialize()
Dim rngDummy As Range
'初期化
Call ktCellMovePad(False, 0, 0, 0, Before_X, Before_Y, lblMousePad, rngDummy )
Set rngActCell = ActiveCell
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngDummy As Range
'マウスパッド用ラベルから外に出たのでリセットする
Call ktCellMovePad(False, 0, 0, 0, Before_X, Before_Y, lblMousePad, rngDummy )
End Sub
Private Sub lblMousePad_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Call ktCellMovePad(True, X, Y, Shift, Before_X, Before_Y, lblMousePad, rngActCell )
End Sub
'----------- ひとつのセル指定（Book/Sheet 切り換えが有る場合） ---------------
' txtBook/txtSheet に選択したブック名/シート名が入っているとする
' Active なセルアドレスを txtCell に表示
Private Before_X As Single
Private Before_Y As Single
Private rngActCell As Range
Private Sub UserForm_Initialize()
Dim rngDummy As Range
'初期化
Call ktCellMovePad(False, 0, 0, 0, Before_X, Before_Y, lblMousePad, rngDummy )
Set rngActCell = Nothing
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngDummy As Range
'マウスパッド用ラベルから外に出たのでリセットする
Call ktCellMovePad(False, 0, 0, 0, Before_X, Before_Y, lblMousePad, rngDummy )
End Sub
Private Sub lblMousePad_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Call ktCellMovePad(True, X, Y, Shift, Before_X, Before_Y, lblMousePad, _
rngActCell, txtBook.Value, txtSheet.Value )
If (rngActCell Is Nothing ) Then
txtCell.Value = ""
Else
If (Application.ReferenceStyle = xlA1) Then
txtCell.Value = rngActCell.Address(False, False, xlA1) 'A1形式
Else
txtCell.Value = rngActCell.Address(True, True, xlR1C1) 'R1C1形式
End If
End If
End Sub
'----------- 複数のセル指定（Book/Sheet 切り換えが無い場合） ---------------
' Active なセルアドレスを txtCell1 に表示（lblMousePad1 ）
' 同様に、txtCell2/lblMousePad2 で処理する
Private Before_X1 As Single
Private Before_Y1 As Single
Private rngActCell1 As Range
Private Before_X2 As Single
Private Before_Y2 As Single
Private rngActCell2 As Range
Private Sub UserForm_Initialize()
Dim rngDummy As Range
'初期化
Call ktCellMovePad(False, 0, 0, 0, Before_X1, Before_Y1, lblMousePad1, rngDummy )
Call ktCellMovePad(False, 0, 0, 0, Before_X2, Before_Y2, lblMousePad2, rngDummy )
Set rngActCell1 = Nothing
Set rngActCell2 = Nothing
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngDummy As Range
'マウスパッド用ラベルから外に出たのでリセットする
Call ktCellMovePad(False, 0, 0, 0, Before_X1, Before_Y1, lblMousePad1, rngDummy )
Call ktCellMovePad(False, 0, 0, 0, Before_X2, Before_Y2, lblMousePad2, rngDummy )
End Sub
Private Sub lblMousePad1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngActTemp As Range
Call ktCellMovePad(True, X, Y, Shift, Before_X1, Before_Y1, lblMousePad1, rngActTemp )
If ((Shift And 1) = 1) Then
'[Shift]押下中のみセル表示を変更
If (Application.ReferenceStyle = xlA1) Then
txtCell1.Value = rngActTemp.Address(False, False, xlA1) 'A1形式
Else
txtCell1.Value = rngActTemp.Address(True, True, xlR1C1) 'R1C1形式
End If
Set rngActCell1 = rngActTemp
Else
'何もしない(セル表示/セル参照は、そのまま)
End If
End Sub
Private Sub lblMousePad2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngActTemp As Range
Call ktCellMovePad(True, X, Y, Shift, Before_X2, Before_Y2, lblMousePad2, rngActTemp )
If ((Shift And 1) = 1) Then
'[Shift]押下中のみセル表示を変更
If (Application.ReferenceStyle = xlA1) Then
txtCell2.Value = rngActTemp.Address(False, False, xlA1) 'A1形式
Else
txtCell2.Value = rngActTemp.Address(True, True, xlR1C1) 'R1C1形式
End If
Set rngActCell2 = rngActTemp
Else
'何もしない(セル表示/セル参照は、そのまま)
End If
End Sub
'----------- 複数のセル指定（Book/Sheet 切り換えが有る場合） ---------------
' txtBook1/txtSheet1 に選択したブック名/シート名が入っているとする
' Active なセルアドレスを txtCell1 に表示（lblMousePad1 ）
' 同様に、txtBook2/txtSheet2/txtCell2/lblMousePad2 で処理する
Private Before_X1 As Single
Private Before_Y1 As Single
Private rngActCell1 As Range
Private Before_X2 As Single
Private Before_Y2 As Single
Private rngActCell2 As Range
Private Sub UserForm_Initialize()
Dim rngDummy As Range
'初期化
Call ktCellMovePad(False, 0, 0, 0, Before_X1, Before_Y1, lblMousePad1, rngDummy )
Call ktCellMovePad(False, 0, 0, 0, Before_X2, Before_Y2, lblMousePad2, rngDummy )
Set rngActCell1 = Nothing
Set rngActCell2 = Nothing
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngDummy As Range
'マウスパッド用ラベルから外に出たのでリセットする
Call ktCellMovePad(False, 0, 0, 0, Before_X1, Before_Y1, lblMousePad1, rngDummy )
Call ktCellMovePad(False, 0, 0, 0, Before_X2, Before_Y2, lblMousePad2, rngDummy )
End Sub
Private Sub lblMousePad1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngActTemp As Range
Call ktCellMovePad(True, X, Y, Shift, Before_X1, Before_Y1, lblMousePad1, rngActTemp, _
txtBook1.Value, txtSheet1.Value )
If (rngActTemp Is Nothing ) Then
txtCell1.Value = "" 'Book/Sheet 指定エラー
Set rngActCell1 = Nothing
Else
If ((Shift And 1) = 1) Then
'[Shift]押下中のみセル表示を変更
If (Application.ReferenceStyle = xlA1) Then
txtCell1.Value = rngActTemp.Address(False, False, xlA1) 'A1形式
Else
txtCell1.Value = rngActTemp.Address(True, True, xlR1C1) 'R1C1形式
End If
Set rngActCell1 = rngActTemp
Else
'何もしな(セル表示/セル参照は、そのまま)
End If
End If
End Sub
Private Sub lblMousePad2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim rngActTemp As Range
Call ktCellMovePad(True, X, Y, Shift, Before_X2, Before_Y2, lblMousePad2, rngActTemp, _
txtBook2.Value, txtSheet2.Value )
If (rngActTemp Is Nothing ) Then
txtCell2.Value = "" 'Book/Sheet 指定エラー
Set rngActCell2 = Nothing
Else
If ((Shift And 1) = 1) Then
'[Shift]押下中のみセル表示を変更
If (Application.ReferenceStyle = xlA1) Then
txtCell2.Value = rngActTemp.Address(False, False, xlA1) 'A1形式
Else
txtCell2.Value = rngActTemp.Address(True, True, xlR1C1) 'R1C1形式
End If
Set rngActCell2 = rngActTemp
Else
'何もしない(セル表示/セル参照は、そのまま)
End If
End If
End Sub