事務処理合理化に petit OA のイージーオーダーシステム
お絵かきロジックアナライザ開発記 その14
ヒントデータをファイルで読書きできるようになりました。これで大きなサイズのロジックを入力するのも安心ですね。ところでこれまではファイル操作そのものの機能部分をプログラミングすることを優先し、前頁で言っていた「ファイル操作に関わる様々なエラーチェック」に関してはなにも手を付けていません。想定されるエラーの洗い出しと、その対処を盛込んでいきましょう。準備段階としてちょっとした‘身辺整理’から進めていきます。
もう一度 変数の整理
ファイル操作に関するいくつかのプロシージャを個別に構築してきましたが、共通する変数が出てきていますので、これらを統合します。前にも同じようなことはやっていますので、特に解説はしません。このようなちょっとした「プログラムのメインテナンス」は、コーディングをしていると結構頻繁に発生するものです。
Option Explicit
Option Base 1 '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0 '未定 = 0
....
....
' モジュール内共用変数宣言
....
....
Dim LpStp1 As Boolean '進捗フラグ
Dim FileNum As Integer 'ファイル番号
Dim TemporaryPath As Variant 'Variant型一時変数
Sub OpenHintFile(Optional ByVal CallSwitch As Boolean)
' 開く
Dim TemporaryPath As Variant 'Variant型一時変数
TemporaryPath = Application.GetOpenFilename _
("お絵かきロジックアナライザヒントファイル,*.nng")
'[ファイルを開く]ダイアログ
....
Sub LoadProc(Optional ByVal CallSwitch As Boolean)
' データロード機能部
Dim FileNum As Integer 'ファイル番号
Dim ReadData As Integer '読込データ
FileNum = FreeFile(0) '使用可能ファイル番号取得
....
Sub SaveAsHintFile(Optional ByVal CallSwitch As Boolean)
' 名前を付けて保存
Dim HintFileName As String 'ヒントファイル名
Dim TargetFilePath As String '操作対象ファイル名フルパス
Dim TemporaryPath As Variant 'Variant型一時変数
HintFileName = HintFilePath 'イニシャルファイル名取得
....
Sub SaveProc(Optional ByVal CallSwitch As Boolean)
' データセーブ機能部
Dim FileNum As Integer 'ファイル番号
ReDim HintHrz(FieldHt, HintWd) 'ヒント領域再定義
ReDim HintVrt(FieldWd, HintHt)
....
ファイル操作に関するエラーチェック
ファイル操作をしていて発生するエラーは「ファイルが見付からない」「読書きできない」「クローズ処理に失敗した」など、ファームウェア側に属するものと、「データ形式が違う」「読込んだ値に矛盾がある」など、アプリケーション側に属するものとがあります。ここでは前者を‘ハードウェアエラー’、後者を‘データエラー’というカタチで分け、異なる扱いをします。
エラーの種類はエラーコードで区別します。ハードウェアエラーを00h〜7Fh、データエラーを80h〜FFhで以下のように定義しておきます。並び順に意味があるものもあるので、定義付けはよく考えた上で決定しています。
00h : エラー無 80h : (空)
01h : ファイルオープンエラー 81h : シートサイズエラー
02h : ファイルクローズエラー 82h : ヒントサイズエラー
03h : データリードエラー 83h : ヒント値エラー
04h : データライトエラー
05h : データ転送エラー
ハードウェアエラーはOn Error GoTo文でトラップし、エラーハンドラ内でエラーコードに従った表示をしてプロシージャを抜けるようにします。例えばファイルオープン時にエラーが発生した場合、Openコマンドの直前でErrorCodeにエラー番号&H1をセットしておけば、エラーハンドラ内で「どんなエラーが発生したか」を判定できます。
ここでチェックしているエラーは、PCがうまく機能している間は発生しません。つまりデバッグのチャンスがなく、本当にエラートラップが機能しているかどうかは判らないというのが正直なトコロです。何か問題があるなら教えて頂ければ幸いです。
気を付けたいのはファイルクローズ処理についてです。ファイルのオープンに失敗した場合、オープンできていないのだからクローズの必要もありません。ファイルクローズでエラーになった場合は、もう一度クローズ処理を行ってもダメでしょうから、この時もクローズ文をスキップさせます。ファイルオープンに成功し、データ読出中にエラーが発生した場合、クローズ処理を行う必要があります。
Option Explicit
Option Base 1 '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0 '未定 = 0
....
....
' モジュール内共用変数宣言
Dim HintLen As Integer '列内ヒント数
....
....
Dim FileNum As Integer 'ファイル番号
Dim ErrorCode As Byte 'エラー番号
Dim TemporaryPath As Variant 'Variant型一時変数
Sub LoadProc(Optional ByVal CallSwitch As Boolean)
' データロード機能部
Dim ReadData As Integer '読込データ
On Error GoTo LoadProcError 'エラーハンドラエントリ
ErrorCode = &H1 'オープンエラー準備
FileNum = FreeFile(0) '使用可能ファイル番号取得
Open HintFilePath For Binary Access Read Lock Write As #FileNum
Seek #FileNum, &H1 'ファイルオープン
ErrorCode = &H3 'リードエラー準備
Get #FileNum, , ReadData 'フィールドサイズ取得
FieldWd = ReadData
....
....
NonoModule.NewLogicSheet '新規シート作成
ErrorCode = &H5 '転送エラー準備
For ScanCnt = 1 To FieldHt '水平ヒント値転送
....
....
Next ScanCnt
ErrorCode = &H0 'エラー無
LoadProcError:
If ErrorCode <> &H0 Then 'エラー警告
Select Case ErrorCode
Case &H1
MsgBox "ファイルオープンに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルオープンエラー"
Case &H2
MsgBox "ファイルクローズに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルクローズエラー"
Case &H3
MsgBox "データの読込に失敗しました。" _
, vbOKOnly + vbCritical, "データ読込エラー"
Case &H5
MsgBox "データの転送に失敗しました。" _
, vbOKOnly + vbCritical, "データ読込エラー"
Case Else
MsgBox "エラーが発生しました。" _
, vbOKOnly + vbCritical, "NonogramAnalyzer"
End Select
End If
If ErrorCode = &H0 Or ErrorCode > &H2 Then
ErrorCode = &H2 'クローズエラー準備
Close #FileNum 'ファイルクローズ
End If
On Error GoTo 0 'エラーハンドラ解除
End Sub
Sub SaveProc(Optional ByVal CallSwitch As Boolean)
' データセーブ機能部
ReDim HintHrz(FieldHt, HintWd) 'ヒント領域再定義
....
....
On Error Resume Next '既存同名ファイル削除
Kill HintFilePath
On Error GoTo 0
On Error GoTo SaveProcError 'エラーハンドラエントリ
ErrorCode = &H1 'オープンエラー準備
FileNum = FreeFile(0) '使用可能ファイル番号取得
Open HintFilePath For Binary Access Write Lock Write As #FileNum
Seek #FileNum, &H1 'ファイルオープン
ErrorCode = &H4 '書込エラー準備
Put #FileNum, , CInt(FieldWd) 'フィールドサイズ書込
Put #FileNum, , CInt(FieldHt)
Put #FileNum, , CInt(HintWd)
Put #FileNum, , CInt(HintHt)
For ScanCnt = 1 To FieldHt
HintLen = HintCntHrz(ScanCnt)
Put #FileNum, , CInt(HintLen) '水平ヒント数書込
If HintLen > 0 Then
For HintCnt = 1 To HintLen '水平ヒント値書込
Put #FileNum, , CInt(HintHrz(ScanCnt, HintCnt))
Next HintCnt
End If
Next ScanCnt
For ScanCnt = 1 To FieldWd
HintLen = HintCntVrt(ScanCnt)
Put #FileNum, , CInt(HintLen) '垂直ヒント数書込
If HintLen > 0 Then
For HintCnt = 1 To HintLen '垂直ヒント値書込
Put #FileNum, , CInt(HintVrt(ScanCnt, HintCnt))
Next HintCnt
End If
Next ScanCnt
ErrorCode = &H0 'エラー無
SaveProcError:
If ErrorCode <> &H0 Then 'エラー警告
Select Case ErrorCode
Case &H1
MsgBox "ファイルオープンに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルオープンエラー"
Case &H2
MsgBox "ファイルクローズに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルクローズエラー"
Case &H4
MsgBox "データの書込に失敗しました。" _
, vbOKOnly + vbCritical, "データ読込エラー"
Case Else
MsgBox "エラーが発生しました。" _
, vbOKOnly + vbCritical, "NonogramAnalyzer"
End Select
End If
If ErrorCode = &H0 Or ErrorCode > &H2 Then
ErrorCode = &H2 'クローズエラー準備
Close #FileNum 'ファイルクローズ
End If
On Error GoTo 0 'エラーハンドラ解除
End Sub
次にデータエラーをチェックします。こちらはアプリケーション内でデータ構造に問題がないかを判定するエラーチェックなので、On Error GoTo文ではなくIf文による判定であり、またバイナリエディタなどでヒントファイルを編集してやればエラー状態をシミュレートすることが可能です。データエラーはヒントファイルのロード時にしか発生しません。セーブではデータ構造に従った書込みを行っているはずで、処理手順に問題がなければイイからです。もし運用時にデータエラーが発生したら、ヒントセーブの手順を見直して下さい。
Sub LoadProc(Optional ByVal CallSwitch As Boolean)
' データロード機能部
Dim ReadData As Integer '読込データ
....
....
Get #FileNum, , ReadData
HintHt = ReadData
If FieldWd > 150 Or FieldHt > 150 Then
ErrorCode = &H81 'フィールドサイズエラー
GoTo LoadProcError
End If
If HintWd > Int((FieldWd + 1) / 2) Or HintHt > Int((FieldHt + 1) / 2) Then
ErrorCode = &H82 'ヒントサイズエラー
GoTo LoadProcError
End If
ReDim HintHrz(FieldHt, HintWd) 'ヒント領域再定義
ReDim HintVrt(FieldWd, HintHt)
ReDim HintCntHrz(FieldHt) 'ヒント数領域再定義
ReDim HintCntVrt(FieldWd)
For ScanCnt = 1 To FieldHt '水平ヒント読込
Get #FileNum, , HintLen
If HintLen > HintWd Then
ErrorCode = &H83 'ヒント数エラー
Exit For
End If
HintCntHrz(ScanCnt) = HintLen 'ヒント数格納
If HintLen > 0 Then
For HintCnt = 1 To HintLen 'ヒント値読込
Get #FileNum, , HintHrz(ScanCnt, HintCnt)
If HintHrz(ScanCnt, HintCnt) > FieldWd Then
ErrorCode = &H83 'ヒント値エラー
Exit For
End If
Next HintCnt
End If
If ErrorCode > &H80 Then Exit For
Next ScanCnt
If ErrorCode > &H80 Then GoTo LoadProcError
For ScanCnt = 1 To FieldWd '垂直ヒント読込
Get #FileNum, , HintLen
If HintLen > HintHt Then
ErrorCode = &H83 'ヒント数エラー
Exit For
End If
HintCntVrt(ScanCnt) = HintLen 'ヒント数格納
If HintLen > 0 Then
For HintCnt = 1 To HintLen 'ヒント値読込
Get #FileNum, , HintVrt(ScanCnt, HintCnt)
If HintVrt(ScanCnt, HintCnt) > FieldHt Then
ErrorCode = &H83 'ヒント値エラー
Exit For
End If
Next HintCnt
End If
If ErrorCode > &H80 Then Exit For
Next ScanCnt
If ErrorCode > &H80 Then GoTo LoadProcError
NonoModule.NewLogicSheet '新規シート作成
....
....
LoadProcError:
If ErrorCode <> &H0 Then 'エラー警告
Select Case ErrorCode
Case &H1
MsgBox "ファイルオープンに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルオープンエラー"
Case &H2
MsgBox "ファイルクローズに失敗しました。" _
, vbOKOnly + vbCritical, "ファイルクローズエラー"
Case &H3
MsgBox "データの読込に失敗しました。" _
, vbOKOnly + vbCritical, "データ読込エラー"
Case &H5
MsgBox "データの転送に失敗しました。" _
, vbOKOnly + vbCritical, "データ読込エラー"
Case &H81
MsgBox "シートサイズが最大値を超過しています。" _
& vbNewLine & "データ形式に誤りがあります。" _
, vbOKOnly + vbCritical, "データ形式エラー"
Case &H82
MsgBox "ヒント数が最大値を超過しています。" _
& vbNewLine & "データ形式に誤りがあります。" _
, vbOKOnly + vbCritical, "データ形式エラー"
Case &H83
MsgBox "ヒント値が最大値を超過しています。" _
& vbNewLine & "データ形式に誤りがあります。" _
, vbOKOnly + vbCritical, "データ形式エラー"
Case Else
MsgBox "エラーが発生しました。" _
, vbOKOnly + vbCritical, "NonogramAnalyzer"
End Select
End If
If ErrorCode = &H0 Or ErrorCode > &H2 Then
ErrorCode = &H2 'クローズエラー準備
Close #FileNum 'ファイルクローズ
End If
On Error GoTo 0 'エラーハンドラ解除
End Sub
イベントの抑制
PCは“割込”によって処理を進めています。例えばマウスがクリックされたら「マウスがクリックされたぞ」という割込が発生し、どの位置でクリックされたかによって対応する処理が行われます。キーボードのESCが押されれば、「ESCキーが押されたよ」という割込が発生し、ダイアログがアクティブならキャンセル処理が行われたり、マクロ実行中であれコードを中断したりします。
このような‘処理のキッカケ’となるアクションをイベントと言い、イベントには周期的に定時で発生するものや、先のマウスクリックのようにランダムに発生するものがあります。イベントが発生すると、実行している処理を中断して、割込プログラムが実行されます。PCのOS(Windowsなど)は様々なイベントにより対応する処理を行うコードの集合体で、‘イベントドリブン’のプログラム群です。
ファイル操作中に変なイベントで処理を中断されるのは好ましくありません。そこでファイル操作処理がひと段落するまで、イベントによる割込を発生させないようにしておきましょう。
Sub LoadProc(Optional ByVal CallSwitch As Boolean)
' データロード機能部
Dim ReadData As Integer '読込データ
With Application '割込無効
.EnableCancelKey = xlDisabled
.EnableEvents = False
End With
On Error GoTo LoadProcError 'エラーハンドラエントリ
....
....
On Error GoTo 0 'エラーハンドラ解除
With Application '割込有効
.EnableEvents = True
.EnableCancelKey = xlInterrupt
End With
End Sub
Sub SaveProc(Optional ByVal CallSwitch As Boolean)
' データセーブ機能部
With Application '割込無効
.EnableCancelKey = xlDisabled
.EnableEvents = False
End With
ReDim HintHrz(FieldHt, HintWd) 'ヒント領域再定義
....
....
On Error GoTo 0 'エラーハンドラ解除
With Application '割込有効
.EnableEvents = True
.EnableCancelKey = xlInterrupt
End With
End Sub
EnableEventsプロパティはTrueでイベントが発生します。イベントを抑制したい部分でFalseに、イベント発生を元に戻したい部分でTrueにすれば、その間で割込が発生しなくなります。EnableCancelKeyプロパティはESCやCtrl+Breakなどによる中断を許可するかどうかを指定します。
ヒント入力の効率アップ
大きなサイズのロジックになると、ヒント入力もひと苦労です。少しでも作業がスムーズに進むよう、入力サポート機能を持たせてみましょう。ヒント欄で数値をキーインし、ENTERを押すと次のヒント入力欄にセル移動するようにしてやれば、矢印キーを押す機会はグンと減ります。またDELキーを押してヒント値を削除した際に、そこから先のヒントを自動的に詰めてやるとか、列単位でのミスがあったときのために1列削除、1列挿入機能を付加えてやるなどの対応をします。
まずはENTERキーによるセル移動を考えます。
Sub KeyHook(ByVal KeyHookEnable As Boolean)
' キーフック
With Application
If KeyHookEnable Then
.OnKey "{ENTER}", "NonoModule.CursorMove" 'ENTERキーフック
.OnKey "~", "NonoModule.CursorMove"
.OnKey "^c", "" 'コピー＆ペースト無効
.OnKey "^v", ""
.OnKey "^x", ""
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = False 'コピー＆ペースト無効
.Controls("コピー(&C)").Enabled = False
.Controls("貼り付け(&P)").Enabled = False
End With
Else
.OnKey "{ENTER}" 'ENTERキーフック解除
.OnKey "~"
.OnKey "^c" 'コピー＆ペースト有効
.OnKey "^v"
.OnKey "^x"
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = True 'コピー＆ペースト有効
.Controls("コピー(&C)").Enabled = True
.Controls("貼り付け(&P)").Enabled = True
End With
End If
End With
End Sub
OnKeyメソッドによる実行プロシージャ名を設定しています。引数KeyHookEnableがTrueならENTERへの割当てが有効、Falseなら無効になります。VBAではテンキーのENTERとフルキーのENTERを区別しているので、両方のキーをフックするようにしています。ついでにCtrl+Cなど、コピペ関連のショートカットキーを無効にしたり、[編集]メニューのコピペコマンドを無効にしたりしていますが、後でシートの右クリックメニューを無効にすることで、このシート上でのコピー&ペースト機能は使えないようになります。
KeyHookプロシージャの呼出しは、(1)Nonogramシートがアクティブになったとき (2)Nonogramブックがアクティブになった際にNonogramシートがアクティブだったとき の2パターンが想定できます。逆にキーフックを解除するのはそれぞれの非アクティブイベントで行います。シートアクティブだけでコトが足りそうな気もするのですが、ブックアクティブ時には前面シートのアクティブイベントが発生しないので、個別にコーディングしなければなりません。
Private Sub Worksheet_Activate()
' シートアクティブイベント
NonoModule.KeyHook True 'キーフック有効
End Sub
Private Sub Worksheet_Deactivate()
' シート非アクティブイベント
NonoModule.KeyHook False 'キーフック解除
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' 右クリックイベント
Cancel = True '右クリックキャンセル
End Sub
Private Sub Workbook_Activate()
' ブックアクティブイベント
NonoModule.SystemSheetDisable 'システムシート非表示
....
....
NonoModule.NonoMenuAdd 'メニュー追加
If ThisWorkbook.ActiveSheet.Name = "Nonogram" Then
NonoModule.KeyHook True 'キーフック有効
End If
End Sub
Private Sub Workbook_Deactivate()
' ブック非アクティブイベント
With Application 'オプション情報復元
.DisplayFormulaBar = FormulaBarSetting
.MoveAfterReturn = CellMoving
.MoveAfterReturnDirection = CellMoveDirection
End With
NonoModule.NonoMenuDel 'メニュー削除
NonoModule.KeyHook False 'キーフック解除
End Sub
さて、ENTERキーが押されたときに呼出されることになったCursorMoveプロシージャを組んでいきます。
Sub CursorMove(Optional ByVal CallSwitch As Boolean)
' セル移動制御
Dim ActiveRow As Integer 'アクティブセル位置
Dim ActiveClm As Integer
ActiveRow = ActiveCell.Row 'アクティブセル位置取得
ActiveClm = ActiveCell.Column
If ActiveRow <= HintHt Then '垂直ヒント領域チェック
If ActiveClm > HintWd And ActiveClm <= HintWd + FieldWd Then
If ActiveCell.Value = vbNullString _
Or ActiveRow = 1 Then '未入力または上限なら次列移行
If ActiveRow < HintHt Then '最下段なら無視(連打対応)
If ActiveClm = HintWd + FieldWd Then '最終列なら水平ヒント領域移行
Cells(HintHt + 1, HintWd + 1).Select
Cells(HintHt + 1, HintWd).Select
Else '最終列以外なら次列移行
Cells(HintHt, ActiveClm + 1).Select
End If
End If
Else '入力値があれば上へ
Cells(ActiveRow - 1, ActiveClm).Select '１つ上へ
End If
Else '対象領域以外はオプション設定
NonoModule.DefaultMove 'の移動先に従う
End If
ElseIf ActiveClm <= HintWd Then '水平ヒント領域チェック
If ActiveRow > HintHt And ActiveRow <= HintHt + FieldHt Then
If ActiveCell.Value = vbNullString _
Or ActiveClm = 1 Then '未入力または左限なら次行移行
If ActiveClm < HintWd Then '最右列なら無視(連打対応)
If ActiveRow = HintHt + FieldHt Then '最終行なら垂直ヒント領域移行
Cells(HintHt + 1, HintWd + 1).Select
Cells(HintHt, HintWd + 1).Select
Else '最終行以外なら次行移行
Cells(ActiveRow + 1, HintWd).Select
End If
End If
Else '入力値があれば左へ
Cells(ActiveRow, ActiveClm - 1).Select '１つ左へ
End If
Else '対象領域以外はオプション設定
NonoModule.DefaultMove 'の移動先に従う
End If
Else
NonoModule.DefaultMove
End If
End Sub
Sub DefaultMove(Optional ByVal CallSwitch As Boolean)
' セル移動オプション設定準拠
Dim RowMove As Integer 'セル移動量
Dim ClmMove As Integer
RowMove = 0 '初期値：移動無
ClmMove = 0
With Application
If .MoveAfterReturn Then
RowMove = (.MoveAfterReturnDirection = xlUp) _
- (.MoveAfterReturnDirection = xlDown)
ClmMove = (.MoveAfterReturnDirection = xlToLeft) _
- (.MoveAfterReturnDirection = xlToRight)
End If
End With
On Error Resume Next
ActiveCell.Offset(RowMove, ClmMove).Activate 'オプション設定準拠移動
On Error GoTo 0
End Sub
アクティブなセルがヒント欄であった場合、次のヒント入力位置に移動します。ヒント値入力がない状態でENTERが押されると、次の行、または次の列に進みます。つまりヒントライン末尾でENTERを2回押せば、次ラインの先頭に移動するので、矢印キーの出番はほとんどなくなるでしょう。
ヒント欄以外でENTERが押された場合は、メニューバーの[ツール]→[オプション]コマンドで[編集]タブに設定された移動方向に準拠した処理を行います。つまり普通のセル移動です。移動方向を決める真理値計算を理解するには、ちょっとした知識が必要です。VBAにおいてBoolean型は16ビットで、Trueは全ビット1、Falseは全ビット0で示されます。つまり16進数で言えばTrue=&HFFFF、False=&H0000なワケです。これは整数で言うと-1と0に当ります。この点を踏まえてコードを眺めてみると、RowMoveは、Application.MoveAfterReturnDirectionプロパティがxlUpだった場合は-1、xlDownだった場合は+1になることが解ります。また同様にClmMoveは、Application.MoveAfterReturnDirectionプロパティがxlToLeftのとき-1、xlDownのとき+1になり、現在のアクティブセルからRowMoveとClmMoveの分オフセットした位置にセル移動すればOKです。
カーソルを進める動作の次は「前に戻る」機能を考えてみましょう。ここでは*キーを押すことで、ENTERのときと逆の動作をさせます。
Sub KeyHook(ByVal KeyHookEnable As Boolean)
' キーフック
With Application
If KeyHookEnable Then
.OnKey "{ENTER}", "NonoModule.CursorMove" 'ENTERキーフック
.OnKey "~", "NonoModule.CursorMove"
.OnKey "{106}", "NonoModule.CursorBack" '｢*｣キーフック
.OnKey "*", "NonoModule.CursorBack"
.OnKey "^c", "" 'コピー＆ペースト無効
.OnKey "^v", ""
.OnKey "^x", ""
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = False 'コピー＆ペースト無効
.Controls("コピー(&C)").Enabled = False
.Controls("貼り付け(&P)").Enabled = False
End With
Else
.OnKey "{ENTER}" 'ENTERキーフック解除
.OnKey "~"
.OnKey "{106}" '｢*｣キーフック解除
.OnKey "*"
.OnKey "^c" 'コピー＆ペースト有効
.OnKey "^v"
.OnKey "^x"
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = True 'コピー＆ペースト有効
.Controls("コピー(&C)").Enabled = True
.Controls("貼り付け(&P)").Enabled = True
End With
End If
End With
End Sub
*キーの設定が2つあるのはENTERのときと同様、フルキーとテンキーのどちらも対応させるためです。それでは機能部分をコーディングしていきましょう。
Sub CursorBack(Optional ByVal CallSwitch As Boolean)
' セル移動戻る
Dim ActiveRow As Integer 'アクティブセル位置
Dim ActiveClm As Integer
Dim BackRow As Integer '移動先セル位置
Dim BackClm As Integer
ActiveRow = ActiveCell.Row 'アクティブセル位置取得
ActiveClm = ActiveCell.Column
BackRow = 0 '移動先セル位置クリア
BackClm = 0
If ActiveClm > HintWd _
And ActiveClm <= HintWd + FieldWd Then '垂直ヒント領域チェック
If ActiveRow < HintHt Then
BackRow = ActiveRow + 1 '一行下移動
BackClm = ActiveClm
ElseIf ActiveRow = HintHt Then
If ActiveClm > HintWd + 1 Then
BackRow = 1 '一行左最上段移動
BackClm = ActiveClm - 1
Do While Cells(BackRow, BackClm).Value = vbNullString
If BackRow >= HintHt Then Exit Do
BackRow = BackRow + 1
Loop
If BackRow > 1 And Cells(BackRow, BackClm).Value <> vbNullString Then _
BackRow = BackRow - 1
Else '水平ヒント最終位置移動
BackRow = HintHt + FieldHt
BackClm = 1
Do While Cells(BackRow, BackClm).Value = vbNullString
If BackClm >= HintWd Then Exit Do
BackClm = BackClm + 1
Loop
If BackClm > 1 And Cells(BackRow, BackClm).Value <> vbNullString Then _
BackClm = BackClm - 1
End If
End If
ElseIf ActiveRow > HintHt _
And ActiveRow <= HintHt + FieldHt Then '水平ヒント領域チェック
If ActiveClm < HintWd Then
BackRow = ActiveRow '一列右移動
BackClm = ActiveClm + 1
ElseIf ActiveClm = HintWd Then
If ActiveRow > HintHt + 1 Then
BackRow = ActiveRow - 1 '一列上最左段移動
BackClm = 1
Do While Cells(BackRow, BackClm).Value = vbNullString
If BackClm >= HintWd Then Exit Do
BackClm = BackClm + 1
Loop
If BackClm > 1 And Cells(BackRow, BackClm).Value <> vbNullString Then _
BackClm = BackClm - 1
Else '垂直ヒント最終位置移動
BackRow = 1
BackClm = HintWd + FieldWd
Do While Cells(BackRow, BackClm).Value = vbNullString
If BackRow >= HintHt Then Exit Do
BackRow = BackRow + 1
Loop
If BackRow > 1 And Cells(BackRow, BackClm).Value <> vbNullString Then _
BackRow = BackRow - 1
End If
End If
End If
If BackRow <> 0 And BackClm <> 0 Then
Cells(BackRow, BackClm).Activate 'アクティブセル変更
End If
End Sub
ヒント欄で*を押すと、ENTERと反対の動きをします。カーソルの動きとしてはShift+TABやBSに近いイメージなのですが、逆にTABでのカーソル送りを設定していない点や、BSでは後退に加えて削除機能も連想させる点を考慮して*キーに割当ててみました。違和感があれば割当てるキーを変更しておいて下さい。
ヒントデータの削除と挿入
「自動で次の入力欄に移動」を搭載することができたので、次に削除や挿入などを追加していきます。キーボード入力をフックしてマクロ実行させる手法は全く同じです。
Sub KeyHook(ByVal KeyHookEnable As Boolean)
' キーフック
With Application
If KeyHookEnable Then
.OnKey "{ENTER}", "NonoModule.CursorMove" 'ENTERキーフック
.OnKey "~", "NonoModule.CursorMove"
.OnKey "{106}", "NonoModule.CursorBack" '｢*｣キーフック
.OnKey "*", "NonoModule.CursorBack"
.OnKey "{DELETE}", "NonoModule.HintDelete" 'DELETEキーフック
.OnKey "+{DELETE}", "NonoModule.LineDelete" 'SHIFT+DELETEキーフック
.OnKey "{INSERT}", "NonoModule.HintInsert" 'INSERTキーフック
.OnKey "+{INSERT}", "NonoModule.LineInsert" 'SHIFT+INSERTキーフック
.OnKey "^c", "" 'コピー＆ペースト無効
.OnKey "^v", ""
.OnKey "^x", ""
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = False 'コピー＆ペースト無効
.Controls("コピー(&C)").Enabled = False
.Controls("貼り付け(&P)").Enabled = False
End With
Else
.OnKey "{ENTER}" 'ENTERキーフック解除
.OnKey "~"
.OnKey "{106}" '｢*｣キーフック解除
.OnKey "*"
.OnKey "{DELETE}" 'DELETEキーフック解除
.OnKey "+{DELETE}" 'SHIFT+DELETEキーフック解除
.OnKey "{INSERT}" 'INSERTキーフック解除
.OnKey "+{INSERT}" 'SHIFT+INSERTキーフック解除
.OnKey "^c" 'コピー＆ペースト有効
.OnKey "^v"
.OnKey "^x"
With .CommandBars("Worksheet Menu Bar").Controls("編集(&E)")
.Controls("切り取り(&T)").Enabled = True 'コピー＆ペースト有効
.Controls("コピー(&C)").Enabled = True
.Controls("貼り付け(&P)").Enabled = True
End With
End If
End With
End Sub
DELやINSを‘+’付きで設定すると、Shift+DELなどの組合せ入力をフックできます。DELとINSではセル単位での削除と挿入、Shiftキー併用時はライン単位での削除と挿入を行うようにします。
Option Explicit
Option Base 1 '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0 '未定 = 0
....
....
' モジュール内共用変数宣言
Dim HintLen As Integer '列内ヒント数
....
....
Dim TemporaryPath As Variant 'Variant型一時変数
Dim SelArea As Range '削除/挿入選択領域情報
Dim SelRow As Integer
Dim SelCol As Integer
Dim SelWd As Integer
Dim SelHt As Integer
Dim ActCell As Range
Dim PushArea As Range '削除後整形領域
Sub HintDelete(Optional ByVal CallSwitch As Boolean)
' ヒント削除
Set SelArea = Selection '選択範囲取得
Set ActCell = ActiveCell
SelRow = SelArea.Row
SelCol = SelArea.Column
SelWd = SelArea.Columns.Count
SelHt = SelArea.Rows.Count
If (SelRow <= HintHt And SelRow + SelHt - 1 <= HintHt _
And SelCol > HintWd And SelCol + SelWd - 1 <= HintWd + FieldWd) _
Or (SelCol <= HintWd And SelCol + SelWd - 1 <= HintWd _
And SelRow > HintHt And SelRow + SelHt - 1 <= HintHt + FieldHt) Then
SelArea.ClearContents 'ヒント値削除
If SelRow > HintHt Then
Set PushArea _
= Range(Cells(SelRow, 1), Cells(SelRow + SelHt - 1, SelCol - 1))
PushArea.Copy
PushArea.Offset(0, SelWd).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(SelRow, 1), Cells(SelRow + SelHt - 1, SelWd)).ClearContents
Else
If SelRow > 1 Then
Set PushArea _
= Range(Cells(1, SelCol), Cells(SelRow - 1, SelCol + SelWd - 1))
PushArea.Copy
PushArea.Offset(SelHt, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(1, SelCol), Cells(SelHt, SelCol + SelWd - 1)).ClearContents
End If
End If
SelArea.Select '選択範囲復帰
ActCell.Activate
Else
MsgBox "選択領域が正しくありません", vbOKOnly + vbExclamation, "ヒント削除"
End If
Set SelArea = Nothing 'オブジェクト変数開放
Set ActCell = Nothing
Set PushArea = Nothing
End Sub
まずは変数定義と削除機能のコーディングです。複数セルをブロック選択している場合も想定していますので、単一セルではなく選択領域全体がチェック対象となり、ヒント領域以外まで選択されている場合はエラー表示させます。選択領域が水平ヒント領域内であれば削除後に右詰め、垂直ヒント領域内であれば削除後に下詰めを行います。
Sub LineDelete(Optional ByVal CallSwitch As Boolean)
' ヒントライン削除
Set SelArea = Selection '選択範囲取得
Set ActCell = ActiveCell
SelRow = SelArea.Row
SelCol = SelArea.Column
SelWd = SelArea.Columns.Count
SelHt = SelArea.Rows.Count
If (SelRow <= HintHt And SelRow + SelHt - 1 <= HintHt _
And SelCol > HintWd And SelCol + SelWd - 1 <= HintWd + FieldWd) _
Or (SelCol <= HintWd And SelCol + SelWd - 1 <= HintWd _
And SelRow > HintHt And SelRow + SelHt - 1 <= HintHt + FieldHt) Then
If ActiveCell.Row > HintHt Then
Range(Cells(SelRow, 1) _
, Cells(SelRow, HintWd)).ClearContents '1行削除
If SelRow + SelHt < HintHt + FieldHt Then
Set PushArea _
= Range(Cells(SelRow + SelHt, 1), Cells(HintHt + FieldHt, HintWd))
PushArea.Copy
Cells(SelRow, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(HintHt + FieldHt - SelHt + 1, 1) _
, Cells(HintHt + FieldHt, HintWd)).ClearContents
End If
Else
Range(Cells(1, SelCol) _
, Cells(HintHt, SelCol)).ClearContents '1列削除
If SelCol + SelWd < HintWd + FieldWd Then
Set PushArea _
= Range(Cells(1, SelCol + SelWd), Cells(HintHt, HintWd + FieldWd))
PushArea.Copy
Cells(1, SelCol).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(1, HintWd + FieldWd - SelWd + 1) _
, Cells(HintHt, HintWd + FieldWd)).ClearContents
End If
End If
SelArea.Select '選択範囲復帰
ActCell.Activate
Else
MsgBox "選択領域が正しくありません", vbOKOnly + vbExclamation, "ヒント削除"
End If
Set SelArea = Nothing 'オブジェクト変数開放
Set ActCell = Nothing
Set PushArea = Nothing
End Sub
続いてShift+DELによる行/列単位での削除です。選択領域が適正かどうかのチェックはセル単位での削除と同じなので問題ないでしょう。水平ヒント領域での行削除では上詰め、垂直ヒント領域での列削除では左詰めにする部分が異なります。
削除処理の次は挿入コマンドをコーディングしていきましょう。
Option Explicit
Option Base 1 '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0 '未定 = 0
....
....
' モジュール内共用変数宣言
Dim HintLen As Integer '列内ヒント数
....
....
Dim PushArea As Range '削除後整形領域
Dim ErrorCheck As Long 'エラーチェック
Dim VectHrz As Boolean '対象ヒント方向
Sub HintInsert(Optional ByVal CallSwitch As Boolean)
' ヒント挿入
Dim CheckArea As Range 'スライド範囲セル領域
Set SelArea = Selection '選択範囲取得
Set ActCell = ActiveCell
SelRow = SelArea.Row
SelCol = SelArea.Column
SelWd = SelArea.Columns.Count
SelHt = SelArea.Rows.Count
VectHrz = (SelRow > HintHt) '挿入先はみ出しチェック
If (SelRow <= HintHt And SelRow + SelHt - 1 <= HintHt _
And SelCol > HintWd And SelCol + SelWd - 1 <= HintWd + FieldWd) _
Or (SelCol <= HintWd And SelCol + SelWd - 1 <= HintWd _
And SelRow > HintHt And SelRow + SelHt - 1 <= HintHt + FieldHt) Then
If VectHrz Then
Set CheckArea = Range(Cells(SelRow, 1), Cells(SelRow + SelHt - 1, SelWd))
Else
Set CheckArea = Range(Cells(1, SelCol), Cells(SelHt, SelCol + SelWd - 1))
End If
If CheckArea.Count = 1 Then
ErrorCheck = 0
If CheckArea.Value = Empty Then ErrorCheck = 1
Else
On Error Resume Next
ErrorCheck = CheckArea.SpecialCells(xlCellTypeConstants).Count
ErrorCheck = Err.Number
On Error GoTo 0
End If
If ErrorCheck = 0 Then
MsgBox "ヒント欄からはみ出します", vbOKOnly + vbExclamation, "挿入エラー"
Else '空欄挿入
If VectHrz Then
Set CheckArea = Cells(SelRow, SelWd + 1)
Else
Set CheckArea = Cells(SelHt + 1, SelCol)
End If
Set PushArea _
= Range(CheckArea, Cells(SelRow + SelHt - 1, SelCol + SelWd - 1))
PushArea.Copy
PushArea.Offset(SelHt * Not VectHrz, SelWd * VectHrz) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
SelArea.ClearContents
End If
SelArea.Select '選択範囲復帰
ActCell.Activate
Else
MsgBox "選択領域が正しくありません", vbOKOnly + vbExclamation, "ヒント削除"
End If
Set SelArea = Nothing 'オブジェクト変数開放
Set ActCell = Nothing
Set PushArea = Nothing
Set CheckArea = Nothing
End Sub
削除の場合と違うのは、挿入によって押し出された内容がヒント欄をはみ出す場合にエラーとしているコトです。そのために挿入時にのみ必要なオブジェクト変数CheckAreaを冒頭で宣言しています(この後の行挿入でも使用する変数は共用変数としてモジュール冒頭で宣言します)。オブジェクト変数CheckAreaは、挿入コマンドによって押し出されるセル領域を示し、ここに何らかのヒント値が設定されていた場合に挿入エラーを警告するようにしています。
ここでやや解説が必要なのが、コードの中で下線を引いた部分です。SpecialCellsメソッドを使って押出される部分にヒント値が入力されていないかどうかをチェックしているのですが、まず注意したいのはSpecialCellsは“プロパティ”ではなく“メソッド”なのです。特定のセルをピックアップできるような使われ方からも誤解しがちなのですが、コマンドで言うと[編集]→[ジャンプ]に相当するもので、例えば[ジャンプ]ダイアログで[セル選択]をクリックし、[空白セル]を選択して[OK]を押した場合のマクロ記録はSelection.SpecialCells(xlCellTypeBlanks).Selectとなります。コード中では「定数のあるセルの数を数える」というような記述になっていますが、指定したセルが見付からない場合、カウント値がゼロになるのではなく、ジャンプできないからエラーが発生することになります。CheckAreaに1つでもヒントが入力されていれば、それを押出す結果となってしまうのでエラーで止めるというコトですが、SpecialCells(xlCellTypeConstants)が1つもない(つまり挿入可能)な場合、Count値はゼロになるのではなく「ジャンプ先は存在しないからマクロエラー」という結果になります。つまりSpecialCellsメソッドを使用しているのは、マクロエラーが起きるかどうかをチェックしているに過ぎません。そのためErrorCheckにCount値を代入したすぐ後にErr.Numberを代入するという、ちょっと変わったコトをしています。
SpecialCellsメソッドが[ジャンプ]コマンドに対応するために特別な処理をしている部分がもうひとつあって、削除対象が1マスだった場合は、そのマス内でのジャンプというものが存在しないため、どうしてもエラーになってしまうので、SpecialCellsメソッドを使わずに、はみ出す部分にヒント値がセットされているかどうかで判定を行っています。
それでは最後にShift+INSによる行/列単位での挿入を考えていきましょう。
Sub LineInsert(Optional ByVal CallSwitch As Boolean)
' ヒントライン挿入
Set SelArea = Selection '選択範囲保存
Set ActCell = ActiveCell
SelRow = SelArea.Row
SelCol = SelArea.Column
SelWd = SelArea.Columns.Count
SelHt = SelArea.Rows.Count
VectHrz = (SelRow > HintHt) '挿入先はみ出しチェック
If (SelRow <= HintHt And SelRow + SelHt - 1 <= HintHt _
And SelCol > HintWd And SelCol + SelWd - 1 <= HintWd + FieldWd) _
Or (SelCol <= HintWd And SelCol + SelWd - 1 <= HintWd _
And SelRow > HintHt And SelRow + SelHt - 1 <= HintHt + FieldHt) Then
If VectHrz Then
If SelRow < HintHt + FieldHt Then
On Error Resume Next
ErrorCheck = Range(Cells(HintHt + FieldHt - SelHt + 1, 1) _
, Cells(HintHt + FieldHt, HintWd)) _
.SpecialCells(xlCellTypeConstants).Count
ErrorCheck = Err.Number
On Error GoTo 0
If ErrorCheck = 0 Then
MsgBox "はみ出す行に" & vbNewLine & "ヒント値が入力されています" _
, vbOKOnly + vbExclamation, "行挿入エラー"
Else '1行挿入
Set PushArea _
= Range(Cells(SelRow, 1), Cells(HintHt + FieldHt - SelHt, HintWd))
PushArea.Copy
PushArea.Offset(SelHt, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(SelRow, 1), Cells(SelRow + SelHt - 1, HintWd)) _
.ClearContents
End If
Else
MsgBox "末尾行です", vbOKOnly + vbExclamation, "行挿入エラー"
End If
Else
If SelCol < HintWd + FieldWd Then
On Error Resume Next
ErrorCheck = Range(Cells(1, HintWd + FieldWd - SelWd + 1) _
, Cells(HintHt, HintWd + FieldWd)) _
.SpecialCells(xlCellTypeConstants).Count
ErrorCheck = Err.Number
On Error GoTo 0
If ErrorCheck = 0 Then
MsgBox "はみ出す列に" & vbNewLine & "ヒント値が入力されています" _
, vbOKOnly + vbExclamation, "列挿入エラー"
Else '1列挿入
Set PushArea _
= Range(Cells(1, SelCol), Cells(HintHt, HintWd + FieldWd - SelWd))
PushArea.Copy
PushArea.Offset(0, SelWd).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Cells(1, SelCol), Cells(HintHt, SelCol + SelWd - 1)) _
.ClearContents
End If
Else
MsgBox "末尾列です", vbOKOnly + vbExclamation, "行挿入エラー"
End If
End If
SelArea.Select '選択範囲復帰
ActCell.Activate
Else
MsgBox "選択領域が正しくありません", vbOKOnly + vbExclamation, "ヒント削除"
End If
Set SelArea = Nothing 'オブジェクト変数開放
Set ActCell = Nothing
Set PushArea = Nothing
End Sub
行挿入と列挿入とをムリヤリ詰込んでいるので少々長いですが、基本的にはセル挿入と同じです。挿入によって押出される部分にヒント値入力がないかどうかをチェックし、問題があれば警告を出すようになっています。
実際に挿入、削除機能を使ってみると、複数セルを選択する場面は皆無で、1マスごと、または1列ごとの操作を行う場合がほとんどです。そのため複数マスを選択している場合は挿入/削除処理を行わないようにするのもテかと思います。そうすればコードはもっと単純になるので、自分独自のオリジナルコードを記述してみてもいいでしょう。
← 前へ → 次へ ▲ ページトップ