ExcelVBAでパイプ処理を行う

概要

Windows APIを利用したパイプ処理をExcelVBAで実装してみたのでまとめておく。パイプ処理の題材はコマンドライン版7Zipを利用したtar-gz形式での圧縮である。

7Zipでtar-gz形式の圧縮を行う場合は一度tar形式にしたあとgzipで圧縮する必要があるが、一度tarファイルを作成した後gzip圧縮するとgzipファイルにtarファイルの情報が格納されてダサい。7Zipには標準出力に圧縮データを吐き出したり標準入力のデータを圧縮する機能があるので、これとパイプを組み合わせてtarファイル情報が格納されていないtar-gz形式の圧縮を行えるようにする。

なお、ExcelVBAを使ったのは開発環境を用意できなかっただけでExcelVBAである理由は全くない。

Windows APIの宣言について

ExcelVBAでパイプ処理を行うにはWindows APIを利用することになるが、Windows APIを利用するには使用する関数や構造体、定数を宣言する必要がある。MSDNライブラリのC/C++用の関数定義を参照してVBA用に書き換えていくことになるが、これが結構大変。実はMicrosoftがVB/VBA用の関数定義を公開してくれているのでこれを利用すると簡単。

x86版
Visual Basic Win32 API Declarations

x64版
Office 2010 Help Files: Win32API_PtrSafe with 64-bit Support

コード

x64版Excel用のコードだが、PtrSafeを削除してLongPtrをLongに修正すればx86版でも動くはず。

標準モジュール

Option Explicit

Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" ( _
    ByRef dest As Any, _
    ByVal numBytes As LongPtr)

Private Declare PtrSafe Function CreatePipe Lib "kernel32" ( _
    ByRef phReadPipe As LongPtr, _
    ByRef phWritePipe As LongPtr, _
    ByRef lpPipeAttributes As SECURITY_ATTRIBUTES, _
    ByVal nSize As Long) As Long

Private Declare PtrSafe Function SetHandleInformation Lib "kernel32" ( _
    ByVal hObject As LongPtr, _
    ByVal dwMask As Long, _
    ByVal dwFlags As Long) As Long

Private Declare PtrSafe Function CreateProcess Lib "kernel32" Alias "CreateProcessA" ( _
    ByVal lpApplicationName As String, _
    ByVal lpCommandLine As String, _
    ByRef lpProcessAttributes As SECURITY_ATTRIBUTES, _
    ByRef lpThreadAttributes As SECURITY_ATTRIBUTES, _
    ByVal bInheritHandles As Long, _
    ByVal dwCreationFlags As Long, _
    ByRef lpEnvironment As Any, _
    ByVal lpCurrentDriectory As String, _
    ByRef lpStartupInfo As STARTUPINFO, _
    ByRef lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare PtrSafe Function GetStdHandle Lib "kernel32" ( _
    ByVal nStdHandle As Long) As LongPtr

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

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

Private Declare PtrSafe Function WriteFile Lib "kernel32" ( _
    ByVal hFile As LongPtr, _
    ByRef lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, _
    ByRef lpNumberOfBytesWritten As Long, _
    ByRef lpOverlapped As OVERLAPPED) As Long

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

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

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

Private 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 LongPtr
    hStdInput As LongPtr
    hStdOutput As LongPtr
    hStdError As LongPtr
End Type

Private Type PROCESS_INFORMATION
    hProcess As LongPtr
    hThread As LongPtr
    dwProcessId As Long
    dwThreadId As Long
End Type

Private Type OVERLAPPED
    Internal As LongPtr
    InternalHigh As LongPtr
    offset As Long
    OffsetHigh As Long
    hEvent As LongPtr
End Type

Private Const HANDLE_FLAG_INHERIT = &H1

Private Const STD_INPUT_HANDLE = -10&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_ERROR_HANDLE = -12&

Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100
Private Const SW_HIDE = 0

Private Const STILL_ACTIVE = &H103

'TAR-GZ形式で圧縮する
'7Zipを利用、TAR形式で圧縮した結果を標準入力から受け取ってGZIP圧縮することでTAR-GZ形式で圧縮する
'コマンド: 7z a dummy -ttar -so "圧縮対象ファイルパス" | 7z a "圧縮ファイルパス" -tgzip -si
Public Function makeTarGz() As Boolean

    Const SEVEN_ZIP_PATH As String = "C:\Users\shela\Desktop\7z\7z.exe" '7Zip実行ファイルパス
    Const TARGET_PATH As String = "C:\Users\shela\Desktop\7z\History.txt"    '圧縮対象ファイルパス
    Const TGZ_PATH As String = "C:\Users\shela\Desktop\7z\History.tgz"   '圧縮ファイルパス
    Const BUFSIZE As Integer = 1024 'バッファサイズ

    Dim sa As SECURITY_ATTRIBUTES
    Dim hInRead As LongPtr
    Dim hInWrite As LongPtr
    Dim hOutRead As LongPtr
    Dim hOutWrite As LongPtr

    Dim pi1 As PROCESS_INFORMATION
    Dim pi2 As PROCESS_INFORMATION
    Dim si1 As STARTUPINFO
    Dim si2 As STARTUPINFO
    Dim saAttr As SECURITY_ATTRIBUTES
    Dim commandLine1 As String
    Dim commandLine2 As String

    Dim dwRead As Long
    Dim dwWritten As Long
    Dim buffer(BUFSIZE - 1) As Byte
    Dim ov1 As OVERLAPPED
    Dim ov2 As OVERLAPPED
    Dim exitCode1 As Long
    Dim exitCode2 As Long

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

    '出力側パイプの作成
    If CreatePipe(hOutRead, hOutWrite, sa, 0) = 0 Then
        MsgBox "パイプの作成に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    '出力側読み込みハンドルを子プロセスに継承できなくする
    If SetHandleInformation(hOutRead, HANDLE_FLAG_INHERIT, 0) = 0 Then
        MsgBox "出力側読み込みハンドルの継承設定に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    '入力側パイプの作成
    If CreatePipe(hInRead, hInWrite, sa, 0) = 0 Then
        MsgBox "パイプの作成に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    '入力側書き込みハンドルを子プロセスに継承できなくする
    If SetHandleInformation(hInWrite, HANDLE_FLAG_INHERIT, 0) = 0 Then
        MsgBox "入力側書き込みハンドルの継承設定に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    'コマンド生成
    'TAR圧縮->標準出力
    commandLine1 = """" & SEVEN_ZIP_PATH & """ a dummy -ttar -so """ & TARGET_PATH & """"
    '標準入力->GZIP圧縮
    commandLine2 = """" & SEVEN_ZIP_PATH & """ a """ & TGZ_PATH & """ -tgzip -si"

    Call ZeroMemory(si1, Len(si1))
    si1.cb = Len(si1)
    si1.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
    si1.hStdOutput = hOutWrite
    si1.hStdError = GetStdHandle(STD_ERROR_HANDLE)
    si1.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    si1.wShowWindow = SW_HIDE

    Call ZeroMemory(si2, Len(si2))
    si2.cb = Len(si2)
    si2.hStdInput = hInRead
    si2.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE)
    si2.hStdError = GetStdHandle(STD_ERROR_HANDLE)
    si2.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    si2.wShowWindow = SW_HIDE

    'プロセス生成(TAR圧縮)
    If CreateProcess(vbNullString, commandLine1, saAttr, saAttr, 1&, 0&, 0&, vbNullString, si1, pi1) = 0 Then
        MsgBox "プロセス生成に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    Call CloseHandle(pi1.hThread)

    'プロセス生成(GZIP圧縮)
    If CreateProcess(vbNullString, commandLine2, saAttr, saAttr, 1&, 0&, 0&, vbNullString, si2, pi2) = 0 Then
        MsgBox "プロセス生成に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    Call CloseHandle(pi2.hThread)

    Do While True
        '終了ステータスコードの取得
        If GetExitCodeProcess(pi1.hProcess, exitCode1) = 0 Then
            MsgBox "終了ステータスの取得に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
            GoTo Error
        End If

        If GetExitCodeProcess(pi2.hProcess, exitCode2) = 0 Then
            MsgBox "終了ステータスの取得に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
            GoTo Error
        End If

        '出力側パイプからデータが読めることを確認する
        If PeekNamedPipe(hOutRead, 0&, 0, 0&, dwRead, ByVal 0) = 0 Then
            MsgBox "パイプからデータ取得に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
            GoTo Error
        End If

        If dwRead > 0 Then
            Erase buffer
            '出力側パイプからデータを読み取る
            If ReadFile(hOutRead, buffer(0), UBound(buffer) + 1, dwRead, ov1) = 0 Then
                Exit Do
            End If

            '読み取ったデータを入力側パイプに書き込む
            If WriteFile(hInWrite, buffer(0), dwRead, dwWritten, ov2) = 0 Then
                Exit Do
            End If
        Else
            If exitCode1 <> STILL_ACTIVE Or exitCode2 <> STILL_ACTIVE Then
                Exit Do
            End If
        End If

        DoEvents
    Loop

    Call CloseHandle(pi1.hProcess)
    Call CloseHandle(hOutWrite)
    Call CloseHandle(hOutRead)

    '終了コードチェック
    If exitCode1 <> 0 And exitCode1 <> STILL_ACTIVE Then
        MsgBox "異常終了しました。終了コード:" & exitCode1, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    ElseIf exitCode2 <> 0 And exitCode2 <> STILL_ACTIVE Then
        MsgBox "異常終了しました。終了コード:" & exitCode2, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    '入力側書き込みハンドルを閉じることでプロセス(GZIP圧縮)の読み込みを終了させる
    Call CloseHandle(hInWrite)

    'プロセス(GZIP圧縮)終了まで待機
    Do
        If GetExitCodeProcess(pi2.hProcess, exitCode2) = 0 Then
            MsgBox "終了ステータスの取得に失敗しました。エラーコード:" & Err.LastDllError, Buttons:=vbCritical, Title:="エラー"
            GoTo Error
        End If
        DoEvents
    Loop While exitCode2 = STILL_ACTIVE

    Call CloseHandle(pi2.hProcess)
    Call CloseHandle(hInRead)

    'プロセス(GZIP圧縮)の終了コードチェック
    If exitCode2 <> 0 Then
        MsgBox "異常終了しました。終了コード:" & exitCode2, Buttons:=vbCritical, Title:="エラー"
        GoTo Error
    End If

    MsgBox "完了しました。", Buttons:=vbInformation, Title:="完了"
    makeTarGz = True
    Exit Function

'エラー処理
Error:
    makeTarGz = False

    Call CloseHandle(pi1.hThread)
    Call CloseHandle(pi1.hProcess)
    Call CloseHandle(pi2.hThread)
    Call CloseHandle(pi2.hProcess)
    Call CloseHandle(hOutWrite)
    Call CloseHandle(hOutRead)
    Call CloseHandle(hInRead)
    Call CloseHandle(hInWrite)
End Function

注意点など

パイプの読み書き

ReadFile関数でパイプからデータを読み込む場合、他のプロセスからパイプにデータが書き込まれるまで処理をブロックする。WriteFile関数でパイプにデータを書き込む場合、パイプのバッファがいっぱいになるとReadFile関数などでパイプからデータが読み出されてバッファがクリアされない限り残りのデータを書き込めず処理をブロックする。

Anonymous Pipe Operations

上記コードのように自分でパイプの読み書きを制御する場合、指定するバッファサイズが大きすぎたり処理の流れを間違えて実装するだけで簡単に停止しないプログラムができてしまうので注意が必要。

7Zipでは-ao(Overwrite mode)スイッチをつけない限り指定した圧縮ファイルが存在するとエラーになるが、(7Zipのソースコードを確認したわけではないが)このチェックはパイプからデータが読み出された後で行われるようで、WriteFile関数で書き込もうとしているデータサイズがパイプのバッファサイズを超えていて7Zip側の読み出しサイズがWriteFile関数で書き込もうとしているデータサイズより小さい場合、WriteFile関数のところで処理が止まってしまってプロセスの終了ステータスを参照しようにもできなくなってしまう。
この場合は、WriteFile関数で書き込もうとしているデータサイズを小さくするか、パイプのバッファサイズを大きくすることで回避できる。

PeekNamedPipe関数

匿名パイプを利用しているのになぜNamed？と少し気になるが、PeekNamedPipe関数はパイプ内にデータが存在していない場合でも即座に応答を返しパイプから読み取ることができる総バイト数を取得できるので、ReadFile関数でデータを読む前のチェックを行っている。

パイプのデータの終端

パイプに書き込むデータはバッファサイズを超えなければ何回に分けて書き込んでも問題ないので、子プロセスがパイプからデータを読み出す場合どこまで(何回)読めばデータの終端になるかあらかじめ知ることはできない。データの終端が分からなければReadFile関数は読み出しバッファがいっぱいになるまで延々とデータを待ち続けてしまう。これでは困るので、CloseHandle関数を呼んで書き込み側ハンドルをクローズすることで子プロセスがデータの終端を分かるようにしている。

パイプのハンドルの継承

CreatePipe関数でパイプを作成する際、SECURITY_ATTRIBUTES構造体のbInheritHandleフィールドで子プロセスにハンドルを継承するように設定できる。ハンドルを継承すると子プロセスからもパイプを操作できるようになる。ただし、書き込みと読み込みの両方のハンドルを継承させてしまうと親プロセスから書き込み側ハンドルをクローズしてもパイプのデータの終端が分からなくなる(子プロセス側からはまだ書き込み側ハンドルを操作できるため)といった問題が発生するので、SetHandleInformation関数やDuplicateHandle関数を利用して片側のハンドルだけを継承できるように設定する。
上記コードでは、SECURITY_ATTRIBUTES構造体でひとまず読み書き両方のハンドルを継承するように設定しSetHandleInformation関数で一方のハンドルを継承しないように設定し直しているが、SECURITY_ATTRIBUTES構造体では両方のハンドルを継承しないように設定しSetHandleInformation関数で一方のハンドルを継承するように設定し直すというやり方でもよい。

終了コード

GetExitCodeProcess関数の第2引数の値でプロセスがまだ実行中(STILL_ACTIVE)なのか終了したのかを検知しているが、実行しているプロセスがエラー時にSTILL_ACTIVEと同じ値(259)を返すような作りになっていると、万一エラーが発生した場合に終了しないプログラムになってしまうので注意。