2

とを使用VBA 6.0しWaitForSingleObjectます。私は比較的新しいVBA 6ので、この問題を抱えています。残念ながら、プロジェクトを VS 2010 にアップグレードすることはできません。コマンド シェルへのパイプを作成し、コマンド ラインを渡して結果を待っています。送信されているコマンドを正確に実行すると、cmd ウィンドウから完全に機能し、errorlevel常に 0 がWaitForSingleObject返されます。 4151以上。

タイムアウトは 60 秒に増加されましたが、違いはありません。無限に設定されている場合、前に進むことはありません (私は何時間も放置しました)。失敗したコマンドは、cmd から実行すると、約 1 秒で出力を終了します。完全なコードは次のとおりです (エラー処理は、返されるデータを確認できるようにコメント アウトされています。データの最初の 4150 バイトが表示されます)。

  Option Explicit

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

  Private Type PROCESS_INFORMATION
      hProcess As Long
      hThread As Long
      dwProcessId As Long
      dwThreadId 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 Byte
      hStdInput As Long
      hStdOutput As Long
      hStdError As Long
  End Type

  Private Const WAIT_LONG             As Long = 60000
  Private Const WAIT_INFINITE         As Long = (-1&)
  Private Const STARTF_USESHOWWINDOW  As Long = &H1
  Private Const STARTF_USECOUNTCHARS  As Long = &H8
  Private Const STARTF_USESTDHANDLES  As Long = &H100
  Private Const SW_HIDE               As Long = 0&
  Private Const SW_SHOWNORMAL         As Long = 1

  Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
  Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
  Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
  Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
  Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
  Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
  Private Declare Sub GetStartupInfo Lib "kernel32" Alias "GetStartupInfoA" (lpStartupInfo As STARTUPINFO)
  Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long

  Public Function Redirect(szBinaryPath As String, szCommandLn As String) As String
      Dim tSA_CreatePipe              As SECURITY_ATTRIBUTES
      Dim tSA_CreateProcessPrc        As SECURITY_ATTRIBUTES
      Dim tSA_CreateProcessThrd       As SECURITY_ATTRIBUTES
      Dim tSA_CreateProcessPrcInfo    As PROCESS_INFORMATION
      Dim tStartupInfo                As STARTUPINFO
      Dim hRead                       As Long
      Dim hWrite                      As Long
      Dim bRead                       As Long
      Dim abytBuff()                  As Byte
      Dim lngResult                   As Long
      Dim szFullCommand               As String
      Dim lngExitCode                 As Long
      Dim lngSizeOf                   As Long
      Dim intReturn                   As Integer

      tSA_CreatePipe.nLength = Len(tSA_CreatePipe)
      tSA_CreatePipe.lpSecurityDescriptor = 0&
      tSA_CreatePipe.bInheritHandle = True

      tSA_CreateProcessPrc.nLength = Len(tSA_CreateProcessPrc)
      tSA_CreateProcessThrd.nLength = Len(tSA_CreateProcessThrd)

      If (CreatePipe(hRead, hWrite, tSA_CreatePipe, 0&) <> 0&) Then
          tStartupInfo.cb = Len(tStartupInfo)
          GetStartupInfo tStartupInfo

          With tStartupInfo
              .hStdOutput = hWrite
              .hStdError = hWrite
              .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
              .wShowWindow = SW_HIDE
          End With

          szFullCommand = """" & szBinaryPath & """" & " " & szCommandLn
          frmCszKUpNS.FullCommand.Text = szFullCommand

          lngResult = CreateProcess(0&, szFullCommand, tSA_CreateProcessPrc, tSA_CreateProcessThrd, _
                                    True, 0&, 0&, vbNullString, tStartupInfo, tSA_CreateProcessPrcInfo)

          If (lngResult <> 0&) Then
              lngResult = WaitForSingleObject(tSA_CreateProcessPrcInfo.hProcess, WAIT_LONG)

              lngSizeOf = GetFileSize(hRead, 0&)
              If (lngSizeOf > 0) Then
                  ReDim abytBuff(lngSizeOf - 1)
                  If ReadFile(hRead, abytBuff(0), UBound(abytBuff) + 1, bRead, ByVal 0&) Then
                      Redirect = StrConv(abytBuff, vbUnicode)
                  End If
              End If
              Call GetExitCodeProcess(tSA_CreateProcessPrcInfo.hProcess, lngExitCode)
              CloseHandle tSA_CreateProcessPrcInfo.hThread
              CloseHandle tSA_CreateProcessPrcInfo.hProcess

              'If (lngExitCode <> 0&) Then Err.Raise vbObject + 1235&, "GetExitCodeProcess", "Non-zero Application exist code"
              CloseHandle hWrite
              CloseHandle hRead
          Else
              'Err.Raise vbObject + 1236&, "CreateProcess", "CreateProcess Failed, Code: " & Err.LastDllError
          End If
      End If
  End Function
4

1 に答える 1

2

パイプはバッファリングされますが、バッファリングには制限があります。バッファーがいっぱいになると、パイプへの書き込みは、バッファーで使用可能なスペースが増えるまでブロックされます。パイプが読み取られると、スペースが使用可能になります。

ライターが終了するまでパイプから何も読み取らず、読み取りが発生するのを待ってライターがブロックされるため、少なくともタイムアウトするまでデッドロックが発生します。明らかに、パイプのバッファーのサイズを発見しました。

1 つの解決策は、書き込みプロセスが終了するのを待たないことです。代わりに、読み取りを開始するだけで、パイプが使用可能になったときにデータを取得できます。読むのに時間をかけすぎて、パイプが枯渇していない場合は、あきらめて、プログラムに時間がかかりすぎていると結論付けることができます。

于 2013-06-12T05:03:52.457 に答える