Hallo Alle,

ich verwende seit längerem ein Makro unter Excel, um ein Programm in einer DOSBox zu starten und den output aus stderr auszulesen. Dazu benutze ich die Windows-API. Nun musste ich das auf Excel365 portieren, was erstmal etwas knifflig war. Nachdem ich nun (hoffentlich) alle Deklarationen in ihre 64bit-Versionen korrigiert habe, läuft das Ding auch durch.

Problem: ich kann zwar ohne weiteres stdout über eine pipee auslesen, eine identisch erzeugte pipe für stderr gibt aber nichts zurück. Ich habe mir beholfen, indem ich beim Programmaufruf stderr auf stdout umleite ("cmd.exe meinprogramm 2>&1"). Das funktioniert zwar, trotzdem wüsste ich gerne was ich falsch mache.

Jemand irgendeine Idee?

Code:

Option VBASupport 1
Option Explicit

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

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

    Private Declare PtrSafe Function PeekNamedPipe Lib "kernel32" ( _
		ByVal hNamedPipe As LongPtr, _
        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 LongPtr
		bInheritHandle As Long
    End Type

    Private Type STARTUPINFO
         cb As Long
         lpReserved As LongPtr
         lpDesktop As LongPtr
         lpTitle As LongPtr
         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 Declare PtrSafe 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 PtrSafe Function CloseHandle Lib "kernel32" (ByVal _
         hObject As LongPtr) As Long
         
        
    Private Declare PtrSafe Function GetExitCodeProcess Lib _
        "kernel32" (ByVal hProcess As LongPtr, lpExitCode _
        As Long) As Long
      
    Private Const SW_SHOWNORMAL = 1
    Private Const SW_HIDE = 0
      
    Private Const STILL_ACTIVE = 259
      
    Private Const NORMAL_PRIORITY_CLASS = &H20&
      
    Private Const STARTF_USESHOWWINDOW = &H1&
    Private Const STARTF_USESTDHANDLES = &H100&
    Public Function ExecCmd(cmdline$) As String
      
        Dim proc As PROCESS_INFORMATION, ret As Long, bSuccess As Long
        Dim start As STARTUPINFO
        Dim sa As SECURITY_ATTRIBUTES, hReadPipe As LongPtr, hWritePipe _
        As LongPtr, hReadPipe2 As LongPtr, hWritePipe2 As LongPtr, ExitCode As Long, _
        tBytesr As Long, tBytesa As Long, tMsg As Long, Result As Long
        
        Dim bytesread As Long, mybuff As String
        Dim i As Integer

        mybuff = String(1024, "A")
        sa.nLength = Len(sa)
        sa.bInheritHandle = 1&
        sa.lpSecurityDescriptor = 0&

        ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
        If ret = 0 Then
            ExecCmd = "Error CreatePipe 1: " & Err.LastDllError
            Exit Function
        End If
        start.hStdOutput = hWritePipe

        ret = CreatePipe(hReadPipe2, hWritePipe2, sa, 0)
        If ret = 0 Then
            ExecCmd = "Error CreatePipe 2: " & Err.LastDllError
            Exit Function
        End If
        start.hStdError = hWritePipe2
        
        start.cb = Len(start)
        start.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
        start.wShowWindow = SW_SHOWNORMAL
       

        ret& = CreateProcessA(0&, cmdline$, sa, sa, 1&, _
                NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
        If ret <> 1 Then
              ExecCmd = "Error CreateProcessA: " & Err.LastDllError
              Exit Function
        End If
        Do
            GetExitCodeProcess proc.hProcess, ExitCode
            
            '**This call returns 0
			'Result = PeekNamedPipe(hReadPipe2, ByVal 0&, 0, ByVal 0&, tBytesa, ByVal 0&)
            
			'**This call works as expected
			Result = PeekNamedPipe(hReadPipe, ByVal 0&, 0&, ByVal 0&, tBytesa, ByVal 0&)

            If Result <> 0 And tBytesa > 0 Then
                bSuccess = ReadFile(hReadPipe, mybuff, 1024, bytesread, 0&)
                If bSuccess = 1 Then
                    ExecCmd = ExecCmd & Left(mybuff, bytesread)
                End If
            End If
            DoEvents
            'Don't quit looping until the app has closed
        Loop While ExitCode = STILL_ACTIVE

        ret& = CloseHandle(proc.hProcess)
        ret& = CloseHandle(proc.hThread)
        ret& = CloseHandle(hReadPipe)
        ret& = CloseHandle(hWritePipe)
        ret& = CloseHandle(hReadPipe2)
        ret& = CloseHandle(hWritePipe2)
    End Function
	
Sub test()
    Dim result As String
    
	'**This call returns nothing
	'result = ExecCmd("cmd.exe /c dir X*")
	
	'**This call returns the expected error
	result = ExecCmd("cmd.exe /c dir X* 2>&1")
    MsgBox (result)
End Sub