エクセルマクロで指定範囲の画面キャプチャ

excelのvbaでスクリーン上の決まった範囲のキャプチャを行うマクロです。

事前準備

・Windowsは64bit環境前提(32bitの場合はAPIの宣言方法が異なります)

・マイドキュメントに空のテキストファイル paste.txtを作成
　形式はカンマ区切りで　x座標1,y座標1,x座標2,y座標2　です。

・Windowsの設定 － アクセシビリティ － キーボードで

　プリントスクリーンボタンを使用して画面切り取りを開く　を オンにしてください。

使い方

・「capture_main」を実行してください

・シフトを押しながら実行で座標の登録、通常実行で画面のキャプチャです。

不具合等ありましたらコメントお願いします。(数か月に1回しかチェックしません)

===================

Option Explicit     '変数宣言の強制

Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long                                 'Windows 起動からの経過時間をミリ秒単位で取得します．

Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long   'マウス操作を行うためのAPIを宣言

Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As coordinate) As Long              'マウスポインター位置の取得

Declare PtrSafe Sub mouse_event Lib "user32" ( _

    ByVal dwFlags As Long, Optional ByVal dx As Long = 0, Optional ByVal dy As Long = 0, _

    Optional ByVal dwDate As Long = 0, Optional ByVal dwExtraInfo As Long = 0)                  'マウスクリック操作

Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)     'キーボード操作

Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer           'シフトキーが押されているか

Type coordinate

    X As Long

    Y As Long

End Type

Const PSC_KEY = &H2C                 ''[PrintScrn]キー

Const KEYEVENTF_EXTENDEDKEY = &H1    ''キーを押す

Const KEYEVENTF_KEYUP = &H2          ''キーを放す

'画面キャプチャのメインプログラム

Sub capture_main()

    Select Case GetKeyState(vbKeyShift)     'シフトキーが押されているかの取得

        Case Is < 0                         'Shiftを押しながらの実行

            Call set_xy                     '座標登録

        Case Else                           '通常実行

            Call scr_capture                'キャプチャ

    End Select

End Sub

'マウスポインター座標を取得して設定ファイルに書き込み

Sub set_xy()

    Dim Cur As coordinate, henji As String, buf As String

    

    henji = MsgBox("マウスをPoint1に合わせてENTERを押してください" & vbCrLf & "はい以外でプログラムを停止します", vbYesNo)

    If henji <> vbYes Then Exit Sub

    

    GetCursorPos Cur                        'マウスカーソル位置取得

    buf = Cur.X & "," & Cur.Y

    

    MsgBox "Point1：（X）" & Cur.X & "（Y）" & Cur.Y & vbCrLf & vbCrLf & _

            "マウスをPoint2に合わせてENTERを押してください"

    

    GetCursorPos Cur                        'マウスカーソル位置取得

    buf = buf & "," & Cur.X & "," & Cur.Y

    Call text_write(buf)                    '設定ファイルに書き込み

End Sub

'画面のキャプチャ

Sub scr_capture()

    Dim xy: xy = text_read                  '設定ファイルから読み込み

    

    keybd_event PSC_KEY, 0, &H1, 0          '[PrintScrn]キーを押す

    keybd_event PSC_KEY, 0, &H1 Or &H2, 0   '[PrintScrn]キーを放す

    WAITmS = 500

    SetCursorPos xy(0), xy(1)               'マウスをPoin1に移動

    mouse_event 2                           '左クリックの押下

    WAITmS = 100

    SetCursorPos xy(2), xy(3)               'マウスをPoin2に移動

    mouse_event 4                           '左クリックを離す

End Sub

'ファイル書き込み 1行

Sub text_write(buf)

    Open mydoc("paste.txt") For Output As #1

    Print #1, buf: Close #1

End Sub

'設定ファイル読み込み 1行

Function text_read()

    Dim buf As String

    Open mydoc("paste.txt") For Input As #1

    Line Input #1, buf: Close #1

    text_read = Split(buf, ",")

End Function

'ファイルにマイドキュメントのパスをつける

Function mydoc(fn)

    mydoc = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & fn

End Function

'WAITmS プロパティmS単位でプロフラムを待機

Public Property Let WAITmS(WaitTime As Long)

    Dim STARTmS As Double, NOWmS As Double              '開始時間(mS)と 現在の時間(mS)の宣言

    

    STARTmS = GetTickCount                              '開始時の時間を取得

    If STARTmS < 0 Then STARTmS = STARTmS + 4294967296#

    Do    '時間待ち

        DoEvents

        NOWmS = GetTickCount                            '現在時刻を取得

        If NOWmS < 0 Then NOWmS = NOWmS + 4294967296#

        If STARTmS > NOWmS Then NOWmS = NOWmS + 4294967296#

    Loop While STARTmS + WaitTime > NOWmS

End Property