【ExcelVBA】keybd_eventでスリープ阻止コード検証

実行中のVBAに長いループ処置があった場合、PCがスリープ状態に入ってしまうとVBAは停止してしまいます。PCの設定を変更できるならば、PC自体の動作設定で対処できますが、職場のPCなどの場合セキュリティ上の問題で設定変更できないことが多いのではないでしょうか。

スリープしないように、時々マウスを動かしたり差し障りのないキーを打ったりして防止していますが、席を離れていればそれは無理です。では、どうしたらよいでしょうか？

VBAの処理中（ループ中）に一定間隔でキーボードイベントを発生させて、キーを押す動作を実行させれば、スリープを回避できるのではないでしょうか。

ということで、実際に検討した内容や問題点とVBAコードを紹介していきます

キーを操作する方法について検証
1. 手軽に使える「SendKeys」メソッドを検証
2. Win32API関数の「keybd_event」を使って検証
キーコード検証の結果「Keybd_event」の採用に決定
1. KeyCode = 0　を検証
2. 結果は次のとおり
前々回の記事で使ったコードに組み込んでみました
1. コードに組み込んだ部分の説明
2. Win32API関数「Sleep」を使用
まとめ
1. いろいろと検証してみた感想
2. 今後は
サンプルファイルをダウンロードできます（下記リンク先へ）

キーを操作する方法について検証

・まず思いつくのはVBAの「SendKeys」メソッドですよね
・Win32APIの「キーボードイベント」も使えそうです

手軽に使える「SendKeys」メソッドを検証

まず思いついたのは「SendKeys」メソッドです
でも問題点があるんですよね（ネットでググると問題点が結構出てきます）

例えば、差しさわりのないキー「Ctrl」を設定したとしましょう

'構文：SendKeys string[, wait]   [, wait]は省略可能   
'wait = False(既定値) プロシージャの終了を待たずに次の行に制御を移します。
'wait = True 処理が終了するまで実行を一時中断します。

SendKeys "^" 　'（^これはCtrlです）でCtrlキーを送信します

では、これってどこに送信するの？　それは、その時アクティブなウィンドウに飛ばすんです

仮にVBA実行中に別プロセスで開いているブックで入力作業していた場合、そこに送られるんです
文字を打ち込んでいた場合そこに「Ctrl」が割り込んでくるんです
大きな影響はないかもしれませんが、打っている文字が入力されなかったり
「V」のキーを入力していた場合「Ctrl+V」でクリップボードにCopyされていた文字列が入力されてしまったりするかもしれません

「Ctrl」ではなく「文字列もじれつ文字列」を「SendKeys」でテストしてみたら
マジで、セルに「文字列もじれつ文字列」が飛んできました(*_*;
どうも動作が安定していない感じがする

目的である「スリープ」は回避できています

席を離れてしまって同時作業を一切行わないのであれば「SendKeys」でも問題ないと思いますが
同時作業を行っている場合では、これは問題ですね！

Win32API関数の「keybd_event」を使って検証

「keybd_event」は、VBAのSendKeysメソッドと同じように任意のキーを操作する命令を出せます「keybd_event」はSendKeysメソッドではできないキー操作が可能です

APIとは、Application Programming Interface（アプリケーション・プログラミング・インターフェース）の略です。「アプリケーションをプログラミングするためのインターフェース」という意味。インターフェイスとは「接点」という意味で、APIを外部に向けて公開することで、ソフトウェアやアプリケーションを開発・共有できるようにしてくれるものです

APIの「keybd_event」を使うには、使用するための宣言をする必要があります。APIに用意されている機能を使うためには必ずこれを使いますという「宣言」をしなければならないので、「SendKeysメソッド」より少し手間がかかります。

「Keybd_event」の使用宣言

'APIの宣言部分
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
　　　　　　　　　　　　　　　　　　　　　ByVal bScan As Byte, _
　　　　　　　　　　　　　　　　　　　　　ByVal dwFlags As Long, _
　　　　　　　　　　　　　　　　　　　　　ByVal dwExtraInfo As Long)
'定数を宣言
Const VK_CONTROL = &H11　> bVkに入れる
Const KEYEVENTF_EXTENDEDKEY = &H1	'押す> dwFlagsに入れる「拡張キー」を使う場合必要
Const KEYEVENTF_KEYUP = &H2			  '放す> dwFlagsに入れる

'bVk：        Keycode
'bScan：      Scancode、常に0
'dwFlags：    0：キーを押す / 1：Scancodeに0xE0を追加 / 2:キーを放す
'dwExtraInfo：常に0

「Keybd_event」コード部分

'Ctrlキー（拡張キーではないけどKEYEVENTF_EXTENDEDKEY使用）をクリックするコード
keybd_event VK_CONTROL, 0, KEYEVENTF_EXTENDEDKEY, 0 'Ctrlキーを押す
keybd_event VK_CONTROL, 0, KEYEVENTF_EXTENDEDKEY　Or KEYEVENTF_KEYUP, 0 'Ctrlキーを放す

実行した結果は「SendKeys」同様、別プロセスで作業しているシートに文字列が飛んできまました(-_-;)

「スリープ」は回避できています
動作自体は「SendKeys」に比べて安定している（変な動作はなかった）感じ

・コントロールキー以外で全く影響が出ないキーってないのかなぁ？
・もう一度いろいろ試してみよう～(^^)/

キーコード検証の結果「Keybd_event」の採用に決定

KeyCode = 0　を検証

その後いろいろなキーコードをテストしましたが、最終的に検証したのはこの２つのコード

'「SendKeys」メソッドのコード
SendKeys "" 　'キーコードや文字列の指定なし


'API「Keybd_event」のコード
keybd_event 0, 0, 0, 0               'KeyCode = 0
keybd_event 0, 0, KEYEVENTF_KEYUP, 0 '放す動作も一応入れています

結果は次のとおり

「SendKeys　””」ではエラーは出ないが「スリープ」を回避できなかった

「KeyCode = 0」のAPI「keybd_event」は「スリープ」を回避できました！
別ブックのシート作業にも何の影響もなく、動作も安定しています
これを使うことに決定だね！！

・API「keybd_event」は「SendKeys」では操作できない特殊キーを操作できます
・例えば「PrtScr」プリントスクリーンキーとか・・・
・今回調べたことを今後のコーディングで生かせるかもしれませんね

前々回の記事で使ったコードに組み込んでみました

前々回の記事はこれです（コードのサンプルは最下部のリンクからダウンロードできます）

【Excel VBA】進捗表示にプログレスバー設置でストレス軽減

VBAで時間のかかる重い処理を実行させる場合、待っている時間はかなりのストレスがかかります。それは、今どのくらい処理が進んでいるのかが見えないからです！そこでこの記事では、プログレスバーを設置してそれを解決する方法について提示していきます

Option Explicit
Private Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
                                    ByVal bScan As Byte, _
                                    ByVal dwFlags As Long, _
                                    ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_EXTENDEDKEY = &H1   'キーを押す
Private Const KEYEVENTF_KEYUP = &H2         'キーを放す

'貼付け元シート上で開始すること
'プログレスバー設置
Sub Array_match()
    Dim workSh As Worksheet, prefSh As Worksheet
    Dim sName As String
    Set prefSh = ThisWorkbook.ActiveSheet
    sName = prefSh.Range("K1").Value    '取得データ貼付け先シート名
    Set workSh = ThisWorkbook.Worksheets(sName)
    Dim ptCol As Long, pFlgCol As Long
    Dim pMCol As Long, pCol() As Long
    Dim wtCol As Long, wFlgCol As Long
    Dim wMCol As Long, wCol() As Long
    Dim pRow As Long, wRow As Long
    Dim i As Long
    Dim percent As Long
    
    '▼マーク（ターゲット）列を検索
    ptCol = Application.WorksheetFunction.Match("▼", prefSh.Rows(2), 0)
    wtCol = Application.WorksheetFunction.Match("▼", workSh.Rows(2), 0)
    '設定行の最大数
    pMCol = Application.WorksheetFunction.Max(prefSh.Rows(2))
    wMCol = Application.WorksheetFunction.Max(workSh.Rows(2))
    'データ開始列の設定
    pRow = prefSh.Range("G1")
    wRow = workSh.Range("G1")
    '設定の不整合を判定する処理
    If pMCol <> wMCol Then
        MsgBox "引き当てる列の数が不整合のため中止します！"
        Exit Sub
    End If
    ReDim pCol(1 To pMCol)  '指定列を代入する
    pFlgCol = 0 '指定列の配置が連続しているかどうか調べる「0」は連続
    For i = 1 To pMCol
        pCol(i) = Application.WorksheetFunction.Match(i, prefSh.Rows(2), 0)
        If i > 1 Then
            If pCol(i) <> pCol(i - 1) + 1 Then pFlgCol = 1 '連続していない場合「1」
        End If
    Next
    ReDim wCol(1 To wMCol)  '貼付け先も同様に調べる
    wFlgCol = 0
    For i = 1 To wMCol
        wCol(i) = Application.WorksheetFunction.Match(i, workSh.Rows(2), 0)
        If i > 1 Then
            If wCol(i) <> wCol(i - 1) + 1 Then wFlgCol = 1 '連続していない場合「1」
        End If
    Next
    Dim workShEndR As Long, prefShEndR As Long
    Dim tgetTmpR As Long, tmpStr As Variant '文字列の場合もあるのでVariantで
    '最終行取得
    workShEndR = workSh.Cells(Rows.Count, wtCol).End(xlUp).Row
    prefShEndR = prefSh.Cells(Rows.Count, ptCol).End(xlUp).Row
    Dim tgetRng As Range
    'ターゲット（ID）の列範囲をセット
    Set tgetRng = Range(prefSh.Cells(pRow, ptCol), prefSh.Cells(prefShEndR, ptCol))
    Dim matchRng As Variant
    Dim MyArray() As Variant
'/////プログレスバー用/////
    Dim lngHcount As Long 'HIT件数カウント用
    Dim starttime As Single
    Dim myspeed As Single
    starttime = Time
    With UserForm1
        .Show vbModeless                'Modelessで表示
        .ProgressBar1.Min = 1           '最小値
        .ProgressBar1.Max = workShEndR  '最大値
        .ProgressBar1.Value = 1         'プログレスバーの初期値
    End With
    Application.Cursor = xlWait         'マウスカーソルを待機中に
    
    Call マクロ開始

    'オートフィルタが設定されていたら解除する
    If (workSh.AutoFilterMode = True) Then workSh.Rows(wRow - 1).AutoFilter
    lngHcount = 0 'ヒット数カウントを初期化
    '開始件数チェック
    If IsNumeric(Range("N1").Value) = True Then
        If Range("N1").Value > wRow Then wRow = Range("N1").Value
    End If
    
    'ターゲットID件数分のループ
    For tgetTmpR = wRow To workShEndR '4 To workShEndR
        DoEvents    '途中で中断ができるように
        tmpStr = workSh.Cells(tgetTmpR, wtCol).Value '検索対象ID
        '発見できなかった場合エラーとなりマクロが停止するので制御する
        On Error Resume Next
        '対象IDコードを配列から検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, tgetRng, 0)
        If Err <> 0 Then
            matchRng = "" 'ERRORの場合空白に
            Err.Clear
        End If
        If matchRng = "" Then
            '何もしない
        Else
            matchRng = matchRng + wRow - 1 '開始行分をプラスする-1
            '配列のメモリ領域割り当て
            ReDim MyArray(1 To pMCol)
            If pFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To pMCol
                    MyArray(i) = prefSh.Cells(matchRng, pCol(i)).Value
                Next
            Else
                MyArray() = prefSh.Range(prefSh.Cells(matchRng, pCol(1)), _
                                prefSh.Cells(matchRng, pCol(pMCol))).Value
            End If
            If wFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To wMCol
                    workSh.Cells(tgetTmpR, wCol(i)).Value = MyArray(i)
                Next
            Else
                workSh.Range(workSh.Cells(tgetTmpR, wCol(1)), _
                        workSh.Cells(tgetTmpR, wCol(pMCol))) = MyArray
            End If
            lngHcount = lngHcount + 1
            Erase MyArray
        End If
        '/////プログレスバーのキャンセルボタン処理/////
        If UserForm1.blCancel = True Then
            Unload UserForm1                'Formを閉じる
            Application.Cursor = xlDefault  'マウスカーソルを戻す
            MsgBox "処理を中断しました。"
            Call マクロ終了
            End
        End If
        'プログレスバーの値表示を更新
        With UserForm1
            If .ProgressBar1.Min < tgetTmpR And _
                .ProgressBar1.Max >= tgetTmpR Then
                'プログレスバーのLabel表示を更新
                percent = CInt(tgetTmpR / workShEndR * 100)
                .Label1.Caption = percent & "%完了【処理件数： " & _
                                tgetTmpR & " / " & workShEndR & " 】" & _
                                "【HIT件数：" & lngHcount & "件】"
                'プログレスバーの値を更新
                .ProgressBar1.Value = tgetTmpR
            End If
        End With
        '//////スリープ防止用_ループ中1000で割り切れるところで実行//////
        If tgetTmpR Mod 1000 = 0 Then
            keybd_event 0, 0, 0, 0 '押す　[KeyCode=0]に設定
            keybd_event 0, 0, KEYEVENTF_KEYUP, 0 '放す
        End If
        DoEvents
        Sleep 1 '1ミリ秒待機
        '//////スリープ防止用////////////////////////////////////////
    Next 
    Call マクロ終了   
    myspeed = Time - starttime      '現在－スタート時刻
    Unload UserForm1                'Formを閉じる
    Application.Cursor = xlDefault  'マウスカーソルを戻す   
    MsgBox "引当て入力が完了しました！" & _
            "処理時間は" & Minute(myspeed) & "分" & _
            Second(myspeed) & "秒 でした" & vbCrLf & _
            "【データ更新件数は： " & lngHcount & " 件でした】", _
            vbInformation, "処理終了メッセージ"
End Sub

コードに組み込んだ部分の説明

・If tgetTmpR Mod 1000 = 0 Then・・・End If　中で「keybd_event」を実行
・Mod 1000 = 0　はループ中1000で割り切れるところで実行する設定にしていますが
・PCがスリープしてしまう時間前に実行するように変更する必要があります
・「DoEvents」と「Sleep」で処理を完了させるようにしています

Win32API関数「Sleep」を使用

・「Sleep」はAPI関数です。「宣言」はつぎのとおりです
・Private Declare Sub Sleep Lib “KERNEL32” (ByVal dwMilliseconds As Long)
・「1秒」＝1000　です。　ここでは「1ミリ秒」=1　を指定しています
・この設定は「KeyCode=0」なので無くても問題なさそうなんですが一応入れておきます

まとめ

いろいろと検証してみた感想

・VBA実行中にPCがスリープしてしまわないようにする設定が完成しました
・Google先生でググると「Ctrl」キーなどを使っているものが多かったけど不満だった
・「keybd_event」で「KeyCode=0」でもスリープを回避できることが判明しました
・「keybd_event」の奥深さを知ることができてよかったです

今後は

今回の記事はいかがだったでしょうか。お役に立てたなら幸いです
Win32APIを利用することでVBAの幅が広がります。もっと勉強してより便利なものが作れるように頑張ります(^^)

【今後の機能追加など…】
・ExcelからOutlook 2016で受信したメールの添付ファイルを保存する方法
・ExcelからOutlook 2016でメールを送信する方法
・データ表から同一種別データ毎に抽出して別ファイルに分割保存する方法
・高速化した「VlookUp関数」のVBAでの活用法を再検討してみたいと思います
・次回はこれらのどれかについて記事にしていきたいと思います。ご期待ください(^^)/