Attribute VB_Name = "ShellExtend"
Option Explicit

Private Declare Function CreateFileA Lib "kernel32" _
    (ByVal lpctStr As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    lpSecurityAttributes As Any, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

Private Declare Function CreatePipe Lib "kernel32" ( _
    phReadPipe As Long, _
    phWritePipe As Long, _
    lpPipeAttributes As Any, _
    ByVal nSize As Long) As Long

Private Declare Function ReadFile Lib "kernel32" ( _
    ByVal hFile As Long, _
    ByVal lpBuffer As String, _
    ByVal nNumberOfBytesToRead As Long, _
    lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Any) As Long

Private Declare Function TerminateProcess Lib "kernel32" (ByVal _
    hProcess As Long, ByVal exitcode As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" _
    (ByVal hObject As Long, ByVal millisecs As Long) As Long

Private Declare Function PeekNamedPipe Lib "kernel32" _
    (ByVal hNamedPipe As Long, lpBuffer As Any, _
    ByVal nBufferSize As Long, lpBytesRead As Long, _
    lpTotalBytesAvail As Long, _
    lpBytesLeftThisMessage As Long) As Long

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Type STARTUPINFO
   cb As Long
   lpReserved As Long
   lpDesktop As Long
   lpTitle As Long
   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 Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Private Declare Function CreateProcessA Lib "kernel32" (ByVal _
   lpApplicationName As Long, ByVal lpCommandLine As String, _
   lpProcessAttributes As Any, lpThreadAttributes As Any, _
   ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
   ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
   lpStartupInfo As Any, lpProcessInformation As Any) As Long

Private Declare Function CloseHandle Lib "kernel32" _
    (ByVal hObject As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" _
    (ByVal hProcess As Long, lpExitCode As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const CREATE_ALWAYS = &H2&
Private Const FILE_ATTRIBUTE_NORMAL = &H80&
Private Const FILE_SHARE_READWRITE = &H3&
Private Const OPEN_EXISTING = &H3&
Private Const INFINITE = &HFFFFFFFF
Private Const WAIT_TIMEOUT = &H102&
Private Const WAIT_OBJECT_0 = &H0&
Private Const WAIT_ABANDONED_WAIT_0 = &H80&
Private Const DETACHED_PROCESS = &H8&



Public Sub ShellWaitSimple(cmdline As String)
    Dim NameOfProc As PROCESS_INFORMATION
    Dim si As STARTUPINFO
    Dim x As Long
    si.cb = Len(si)
    x = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, si, NameOfProc)
    x = CloseHandle(NameOfProc.hProcess)
End Sub

' VB 組み込みの Shell 関数の改良版。
' 起動したプログラムが終了するまで待ち、
' 結果を出力したファイル名を返す。エラー時は "NUL" を返す
Function ShellWait(cmdline As String) As String
    Dim ret As Long
    Dim hTmpFile As Long
    Dim hNullFile As Long
    Dim start As STARTUPINFO
    Dim sa As SECURITY_ATTRIBUTES
    Dim proc As PROCESS_INFORMATION
    Dim sTmpFile As String
    Dim i As Integer
    
    ' エラー終了時に備え仮に値を入れておく
    ShellWait = "NUL"
    ' 一時ファイル名を決定
    sTmpFile = CreateObject("Scripting.FileSystemObject").GetTempName

    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&

    ' 一時ファイルを作成
    hTmpFile = CreateFileA(sTmpFile, GENERIC_WRITE, 0&, sa, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_NORMAL, 0&)
    If (hTmpFile = -1) Then
        MsgBox "CreateFile(" & sTmpFile & ") failed. Error: " & Err.LastDllError
        Exit Function
    End If
    hNullFile = CreateFileA("NUL", GENERIC_READ, FILE_SHARE_READWRITE, sa, _
        OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)

    start.cb = Len(start)
    start.dwFlags = STARTF_USESTDHANDLES
    start.hStdOutput = hTmpFile
    start.hStdError = hTmpFile
    start.hStdInput = hNullFile
    
    ' Start the shelled application:
    ret& = CreateProcessA(0&, cmdline$, sa, sa, 1&, _
        (NORMAL_PRIORITY_CLASS Or DETACHED_PROCESS), _
        0&, 0&, start, proc)
    If (ret = 0) Then
        MsgBox "CreateProcess failed. Error: " & Err.LastDllError
        Exit Function
    End If

    ret& = WaitForSingleObject(proc.hProcess, 60000)
    Do While (ret = WAIT_TIMEOUT)
        ret& = MsgBox("<" & cmdline$ & "> still running, will wait for a minute.", _
            vbYesNoCancel)
        If (ret = vbNo) Then GoTo cleanup
        If (ret = vbCancel) Then
            GoTo cleanup
        End If
        ret& = WaitForSingleObject(proc.hProcess, 60000)
    Loop
    
cleanup:
    ShellWait = sTmpFile
    ret& = CloseHandle(proc.hProcess)
    ret& = CloseHandle(proc.hThread)
    ret& = CloseHandle(hTmpFile)
    ret& = CloseHandle(hNullFile)

End Function
 
Sub GetShellList(ByVal cmdline As String, list As Collection)
    Dim filename As String
    Dim line As String
    Dim ifile As Integer
    Set list = New Collection
    filename = ShellWait(cmdline)
    ifile = FreeFile
    Open filename For Input As #ifile
    Do Until EOF(ifile)
        Input #ifile, line
        list.Add line
    Loop
    Close #ifile
    Kill filename
End Sub

Sub GetPipeList(ByVal cmdline As String, list As Collection)
    Dim ret As Long
    Dim hReadPipe As Long
    Dim hWritePipe As Long
    Dim hNullFile As Long
    Dim sa As SECURITY_ATTRIBUTES
    Dim proc As PROCESS_INFORMATION
    
    ' list を初期化
    Set list = New Collection
    
    ' パイプを作成
    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&
    ret = CreatePipe(hReadPipe, hWritePipe, sa, 10240)
    If (ret = 0) Then
        MsgBox "CreatePipe failed: " & Err.LastDllError
        Exit Sub
    End If

    ' 一時ファイルを作成
    hNullFile = CreateFileA("NUL", GENERIC_READ, _
        FILE_SHARE_READWRITE, sa, _
        OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0&)
    If (hNullFile = -1) Then
        MsgBox "CreateFile(NUL) failed. Error: " & Err.LastDllError
        Exit Sub
    End If

    ' プログラム cmdline を起動
    Dim start As STARTUPINFO
    start.cb = Len(start)
    start.dwFlags = STARTF_USESTDHANDLES
    start.hStdOutput = hWritePipe
    start.hStdError = hWritePipe
    start.hStdInput = hNullFile
    
    ret& = CreateProcessA(0&, cmdline$, sa, sa, 1&, _
        (NORMAL_PRIORITY_CLASS Or DETACHED_PROCESS), _
        0&, 0&, start, proc)
    If (ret = 0) Then
        MsgBox "CreateProcess failed. Error: " & Err.LastDllError
        GoTo cleanupFiles
    End If

    '--- 子を作ったら自分は書く権利を放棄 ---
    ' これを怠ると子が死んでもファイルエンドが来ずにハングする
    ret& = CloseHandle(hWritePipe)

    '--- ファイル書き出しをウォッチ
    Const lenBuffer As Integer = 10240
    Dim fixBuffer As String * lenBuffer
    Dim rbytes As Long
    Dim outstr As String
    Dim availBytes As Long
    outstr = ""
    
    Do
        ret& = ReadFile(hReadPipe, fixBuffer, lenBuffer, rbytes, 0&)
        If (ret& = 0) Then
            If (Err.LastDllError <> 109) Then
                MsgBox "ReadFile Error: " & Err.LastDllError
            End If
            GoTo EndOfPipe
        ElseIf (rbytes = 0) Then
            GoTo EndOfPipe
        End If
        outstr = outstr & Left(fixBuffer, rbytes)
    Loop
EndOfPipe:
        
    '--- 子プロセス停止を待つ
    Dim exitcode As Long
    ret& = WaitForSingleObject(proc.hProcess, INFINITE)
    ret& = GetExitCodeProcess(proc.hProcess, exitcode)
    ret& = CloseHandle(proc.hProcess)
    ret& = CloseHandle(proc.hThread)
    If (exitcode <> 0) Then
        MsgBox "command <" & cmdline & "> exit code = " _
            & exitcode & Chr(13) & Chr(10) & outstr
        GoTo cleanupFiles
    End If
    
    '--- 出力リストの解析
    Call StringSplit(outstr, "", list)
    
    '--- パイプの後始末
cleanupFiles:
    ret& = CloseHandle(hReadPipe)
    ret& = CloseHandle(hNullFile)

End Sub

