Option Compare Database
Option Explicit

'----------------------------------------------------------------------------------------------------------------------------------
'クラス名またはキャプションタイトルを与えてウィンドウハンドルを取得する
'
'戻り値
'正常　 = 指定したクラスとウィンドウ名を持つウィンドウのハンドル
'エラー = NULL
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'----------------------------------------------------------------------------------------------------------------------------------
'既存のプロセスオブジェクトのハンドルを返す
'
'戻り値
'正常　 = 指定したプロセスのオープンハンドル
'エラー = NULL
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const SYNCHRONIZE = &H100000             'WindowsNTのみ:待機関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_TERMINATE = &H1&           'TerminateProcess関数でプロセスのハンドルが使えるようする
Public Const PROCESS_CREATE_THREAD = &H2&       'CreateRemoteThread関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_VM_OPERATION = &H8&        'VirtualProtectEx関数、WriteProcessMemory関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_VM_READ = &H10&            'ReadProcessMemory関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_VM_WRITE = &H206&          'WriteProcessMemory関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_DUP_HANDLE = &H40&         'DuplicateHandle関数の複製元または複製先としてプロセスのハンドルが使えるようにする
Public Const PROCESS_CREATE_PROCESS = &H80&     '内部的に使用される
Public Const PROCESS_SET_INFORMATION = &H200&   'SetPriorityClass関数でプロセスのハンドルが使えるようにする
Public Const PROCESS_QUERY_INFORMATION = &H400& 'GetExitCodeProcess関数、GetPriorityClass関数でプロセスハンドルが使えるようにする
Public Const PROCESS_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF)
                                                '可能な限りのすべてのアクセスを指定する
'----------------------------------------------------------------------------------------------------------------------------------
'指定されたプロセスの終了状態を返す
'
'戻り値
'正常　 = 0以外
'エラー = 0
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
    
'指定したプロセスの終了を判定する定数
'(終了していないときはSTILL_ACTIVEが格納される)
Public Const STATUS_PENDING = &H103&
Public Const STILL_ACTIVE = STATUS_PENDING
'----------------------------------------------------------------------------------------------------------------------------------
'オープンしているオブジェクトハンドルをクローズする
'
'戻り値
'正常　 = 0以外
'エラー = 0
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'----------------------------------------------------------------------------------------------------------------------------------
'新しいプロセスとそのプライマリスレッドを作成する
'
'戻り値
'正常　 = 0以外
'エラー = 0
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" _
    (ByVal lpApplicationName As String, _
    ByVal lpCommandLine As String, _
    lpProcessAttributes As SECURITY_ATTRIBUTES, _
    lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    lpEnvironment As Any, _
    ByVal lpCurrentDriectory As String, _
    lpStartupInfo As STARTUPINFO, _
    lpProcessInformation As PROCESS_INFORMATION) As Long

'ハンドルが子プロセスによって継承されるかどうかを指定する構造体
Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

'新しいプロセスのウィンドウの表示方法を指定する構造体
Type STARTUPINFO
    cb As Long
    lpReserved As String
    lpDesktop As String
    lpTitle As String
    dwX As Long
    dwY As Long
    dwXSize As Long
    dwYSize As Long
    dwXCountChars As Long
    dwYCountChars As Long
    dwFillAttribute As Long
    dwFlags As Long
    wShowWindow As Integer
    cbReserved2 As Integer
    lpReserved2 As Byte
    hStdInput As Long
    hStdOutput As Long
    hStdError As Long
End Type

'新しいプロセスに関する情報を受け取る構造体
Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type

Public Const STARTF_USESHOWWINDOW = &H1         'wShowWindowを使用する
Public Const STARTF_USESIZE = &H2               'dwXSizeとdwYSizeを使用する
Public Const STARTF_USEPOSITION = &H4           'dwXとdwYを使用する
Public Const STARTF_USECOUNTCHARS = &H8         'dwXCountCharsとdwYCountCharsを使用する
Public Const STARTF_USEFILLATTRIBUTE = &H10     'dwFillAttributeを使用する
Public Const STARTF_FORCEONFEEDBACK = &H40      '子の関数呼び出し後、2秒間はカーソルをフィードバックモードにする
Public Const STARTF_FORCEOFFFEEDBACK = &H80     'プロセスの起動と同時にカーソルのフィードバックモードを解除する
Public Const STARTF_USESTDHANDLES = &H100       'hStdInputとhStdOutputとhStdErrorを使用する

Public Const SW_HIDE = 0                        'ウィンドウを非表示にし他のウィンドウをアクティブにする
Public Const SW_SHOWNORMAL = 1                  'ウィンドウをアクティブにして表示する。ウィンドウが最小化または最大化されているときは位置とサイズを元に戻す
Public Const SW_SHOWMINIMIZED = 2               'ウィンドウをアクティブにして最小化する
Public Const SW_SHOWMAXIMIZED = 3               'ウィンドウをアクティブにして最大化する
Public Const SW_SHOWNOACTIVATE = 4              'ウィンドウを直前の位置とサイズで表示する。アクティブなウィンドウはアクティブな状態を維持する
Public Const SW_SHOW = 5                        'ウィンドウをアクティブにして現在の位置とサイズで表示する
Public Const SW_MAXIMIZE = 3                    'ウィンドウを最大化する
Public Const SW_MINIMIZE = 6                    'ウィンドウを最小化しZ順位が次のトップレベルウィンドウをアクティブにする
Public Const SW_SHOWMINNOACTIVE = 7             'ウィンドウを最小化する。アクティブなウィンドウはアクティブな状態を維持する。非アクティブなウィンドウは非アクティブなまま
Public Const SW_SHOWNA = 8                      'ウィンドウを現在の状態で表示する。アクティブなウィンドウはアクティブな状態を維持する
Public Const SW_RESTORE = 9                     'ウィンドウをアクティブにして表示する。ウィンドウが最小化または最大化されているときは位置とサイズを元に戻す
Public Const SW_SHOWDEFAULT = 10                'プリケーションを起動させたプログラムがCreateProcess関数に渡すSTARTUPINFO構造体のwShowWindowメンバで指定されたSW_フラグを基にして表示状態を設定する

Public Const DEBUG_PROCESS = &H1&                   '呼び出し側プロセスがデバッガーのときに指定する。新しいプロセスはデバッグされるプロセスとして扱われそのプロセス内で起きるすべてのデバッグイベントが呼び出し側スレッドに通知される
Public Const DEBUG_ONLY_THIS_PROCESS = &H2&         '呼び出し側プロセスがデバッガーのときに指定する。このフラグを指定しない場合新しいプロセスは呼び出し側プロセスのデバッガーでデバッグされるほかのプロセスになる
Public Const CREATE_SUSPENDED = &H4&                '新しいプロセスをプライマリースレッドをサスペンド状態にして起動する。スレッドを実行するにはResumeThread関数を使う
Public Const DETACHED_PROCESS = &H8&                '新しいプロセスに親プロセスのコンソールへのアクセスを持たせない。新しいプロセスはAllocConsole関数を使って新しいコンソールを作成できる。CREATE_NEW_CONSOLEフラグと同時に指定することはできない
Public Const CREATE_NEW_CONSOLE = &H10&             '新しいプロセスに親のコンソールを継承させず新しいコンソールを持たせる。DETACHED_PROCESSと同時に指定することはできない
Public Const NORMAL_PRIORITY_CLASS = &H20&          '特別なスケジューリングを必要としない一般的なプロセスであることを示す
Public Const IDLE_PRIORITY_CLASS = &H40&            'システムがアイドル状態のときにだけ実行するプロセスであることを示す
Public Const HIGH_PRIORITY_CLASS = &H80&            'タイムクリティカルなタスクを実行するプロセスであることを示す
Public Const REALTIME_PRIORITY_CLASS = &H100&       '最も高い優先順位クラスを持つプロセスであることを示す。このクラスのスレッドは重要なタスクを行うオペレーティングシステムのプロセスを含むほかのすべてのプロセスのスレッドよりも先に実行される。少しでも長い時間実行するとディスクキャッシュがフラッシュされなくなったりマウスが応答しなくなったりする
Public Const CREATE_NEW_PROCESS_GROUP = &H200&      '新しいプロセスを新しいプロセスグループのルートプロセスにする
Public Const CREATE_UNICODE_ENVIRONMENT = &H400&    'lpEnvironmentパラメータが指す環境ブロックがUnicode文字を使用していることを示す。デフォルトではANSI文字が使用されているものとみなされる
Public Const CREATE_SEPARATE_WOW_VDM = &H800&       'WindowsNTのみ:新しいプロセスをプライベートな仮想DOSマシン上で実行させる。このフラグは16ビットのWindowsアプリケーションを起動するときにだけ有効
Public Const CREATE_SHARED_WOW_VDM = &H1000&        'WindowsNTのみ:WIN.INIファイルのWindowsセクション内のDefaultSeparateVDMスイッチがTRUEのときそのスイッチを無効にし新しいプロセスを共有された仮想DOSマシン上で実行させる。このフラグは16ビットのWindowsアプリケーションを起動するときにだけ有効
Public Const CREATE_DEFAULT_ERROR_MODE = &H4000000  '新しいプロセスに呼び出し側プロセスのエラーモードを継承させない。新しいプロセスにはデフォルトのエラーモードを適用する
'----------------------------------------------------------------------------------------------------------------------------------
'指定されたオブジェクトがシグナル状態になるか、タイムアウト時間が経過すると制御を返す
'
'戻り値
'正常　 = 関数が戻る原因となったイベントを表す定数
'エラー = WAIT_FAILED
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

'指定したオブジェクトはシグナル状態になった
Public Const STATUS_WAIT_0 = &H0&
Public Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)

'タイムアウト時間が経過して制御が返った。指定したオブジェクトは非シグナル状態のまま
Public Const STATUS_TIMEOUT = &H102&
Public Const WAIT_TIMEOUT = STATUS_TIMEOUT

'指定されたオブジェクトは放棄されたミューテックスオブジェクト(あるスレッドが所有権を持っていたがそのスレッドは所有権を解放しないで終了した)。
'この関数の呼び出しによりミューテックスの所有権は呼び出し側スレッドに移り非シグナル状態になった
Public Const STATUS_ABANDONED_WAIT_0 = &H80&
Public Const WAIT_ABANDONED = ((STATUS_ABANDONED_WAIT_0) + 0)

'関数の呼び出し失敗
Public Const WAIT_FAILED = &HFFFFFFFF

'タイムアウト時間を無制限にする
Public Const INFINITE = &HFFFFFFFF
'----------------------------------------------------------------------------------------------------------------------------------
'指定されたプロセスがユーザーからの入力を待っている状態になるまで待機する
'
'戻り値
'正常　 = 0
'エラー = WAIT_TIMEOUT or -1&
'----------------------------------------------------------------------------------------------------------------------------------
Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long

'Windowsディレクトリを取得
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Sub LsFindWindow()
'アプリケーションの重複起動を回避
    Dim RtnCd As Long
    Dim id As Long
    
    '電卓のウィンドウハンドルを取得
    RtnCd = FindWindow(vbNullString, "電卓")
                    
    'ウィンドウハンドル（RtnCd）が取得できたら電卓は起動してる
    If RtnCd <> 0 Then
        MsgBox "電卓はすでに起動されています"
        Exit Sub
    End If
    
    '電卓を起動
    RtnCd = Shell("Calc.exe", vbNormalFocus)
    If RtnCd = 0 Then
        MsgBox "電卓の起動に失敗しました"
        Exit Sub
    End If
End Sub

Sub LsGetExitCodeProcess()
'起動したアプリケーションが終了するまで待機する
    Dim TaskID As Long
    Dim lngProcess As Long      'OpenProcess関数の戻り値
    Dim lngExitCode As Long     '終了コード
    Dim RtnCd As Long
     
    MsgBox "メモ帳が起動したらメモ帳を閉じてください"
           
    'メモ帳を起動
    TaskID = Shell("Notepad.exe", vbNormalFocus)

    'Shell関数で起動したアプリケーションのプロセスオブジェクトのハンドルを取得
    lngProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 1, TaskID)
                            
    Do
        'プロセスの終了状態を取得
        RtnCd = GetExitCodeProcess(lngProcess, lngExitCode)
        DoEvents
    Loop While lngExitCode = STILL_ACTIVE

    'オープンしているオブジェクトハンドルをクローズする
    RtnCd = CloseHandle(lngProcess)

    MsgBox "メモ帳が終了しました"
End Sub

Function LsWaitForSingleObject(lpApplicationName As String, dwMilliseconds As Long) As Long
'待機時間を指定してアプリケーションが終了するまで待機する
'lpApplicationName=実行モジュール名
'dwMilliseconds=待機するタイムアウト時間(ミリ秒)
    Dim udtProcessAttributes As SECURITY_ATTRIBUTES
    Dim udtThreadAttributes As SECURITY_ATTRIBUTES
    Dim udtStartupInfo As STARTUPINFO
    Dim udtProcessInfomation As PROCESS_INFORMATION
    Dim RtnCd As Long, Rtndummy As Long
    Dim msg As String
    
    '構造体のバイト数を指定
    udtProcessAttributes.nLength = Len(udtProcessAttributes)
    udtThreadAttributes.nLength = Len(udtThreadAttributes)
    
    '構造体のバイト数を指定
    udtStartupInfo.cb = Len(udtStartupInfo)
    
    '新しいプロセスを作成
    'WindowsXPでは使用不可
    RtnCd = CreateProcess(lpApplicationName, vbNullString, udtProcessAttributes, udtThreadAttributes, False, 0, vbNullString, vbNullString, udtStartupInfo, udtProcessInfomation)
                        
    
    '新しいプロセスがシグナル状態になるまで待機
    RtnCd = WaitForSingleObject(udtProcessInfomation.hProcess, dwMilliseconds)
    LsWaitForSingleObject = RtnCd
    'オープンしているオブジェクトハンドルをクローズする
    Rtndummy = CloseHandle(udtProcessInfomation.hProcess)
End Function

Sub LsCreateProcess()
'ウィンドウの表示位置とサイズを指定してアプリケーションを起動する
    Dim lpApplicationName As String
    Dim udtProcessAttributes As SECURITY_ATTRIBUTES
    Dim udtThreadAttributes As SECURITY_ATTRIBUTES
    Dim udtStartupInfo As STARTUPINFO
    Dim udtProcessInfomation As PROCESS_INFORMATION
    Dim RtnCd As Long
    
    MsgBox "表示位置(50,50)、表示サイズ(500×500)でメモ帳を起動します"

    '実行モジュール名
    lpApplicationName = LsGetWindowsDirectory & "\Notepad.exe"
    
    '構造体のバイト数を指定
    udtProcessAttributes.nLength = Len(udtProcessAttributes)
    udtThreadAttributes.nLength = Len(udtThreadAttributes)
    
    '新しいプロセスのメインウィンドウの表示状態を指定
    With udtStartupInfo
        .cb = Len(udtStartupInfo)
        .dwX = 50
        .dwY = 50
        .dwXSize = 400
        .dwYSize = 400
        .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESIZE Or STARTF_USEPOSITION
        .wShowWindow = SW_SHOWNORMAL
    End With
    
    '新しいプロセスを作成
    RtnCd = CreateProcess(lpApplicationName, vbNullString, udtProcessAttributes, udtThreadAttributes, False, 0, ByVal vbNullString, vbNullString, udtStartupInfo, udtProcessInfomation)
                        
    '新しいプロセスの情報をイミディエイトウィンドウに表示
    With udtProcessInfomation
        MsgBox "新しいプロセスの情報" & vbCr & _
                "  プロセスハンドル: " & Hex(.hProcess) & vbCr & _
                "  プロセスID: " & Hex(.dwProcessId) & vbCr & _
                "  スレッドハンドル: " & Hex(.hThread) & vbCr & _
                "  スレッドID: " & Hex(.dwThreadId)
    End With
End Sub

'Windowsディレクトリを取得
Function LsGetWindowsDirectory() As String
    Dim Gwdvar As String, Gwdvar_Length As Long
    Gwdvar = Space(255)
    Gwdvar_Length = GetWindowsDirectory(lpBuffer:=Gwdvar, nSize:=255)
    '2002/10/09 Bug Fix
    'LsGetWindowsDirectory = Trim$(Left$(Gwdvar, Gwdvar_Length))
    LsGetWindowsDirectory = LsNullTrim(Gwdvar)
End Function
'文字列の最初の vbNullChar[chr$(0)] までを抜き出す
Public Function LsNullTrim(strExp As String) As String
    Dim i As Integer
    
    i = InStr(strExp, vbNullChar)
    If i > 0 Then
        LsNullTrim = Left$(strExp, i - 1)
    Else
        LsNullTrim = strExp
    End If
End Function