Attribute VB_Name = "CaptureConsole"
Option Explicit
'-----------------------------
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
'------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
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 Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
'------------------------------------------------------
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const SW_HIDE As Integer = 0
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STATUS_PENDING As Long = &H103&
Private Const BufferReadSize As Long = 10240 'Tamaño del buffer para leer la salida de consola, este tamaño puede limitar la compatibilidad de su aplicación con ciertos sisteamas operativos
Private Const CTRL_C_EVENT = 0
'------------------------------------------------------

'''''''''''''''''''''''''''''
'APIs
'''''''''''''''''''''''''''''
'Estas apis están incluídas en Windows XP y posteriores
'por lo que la compatibilidad de tu programa estará limitará a esos sistemas

'------------------------------
'CreatePipe Crea los pipes anónimos necesarios para redirigir los mensajes de consola
'Se crean dos pipes: uno para los mensajes de salida y otro para los de entrada
'El pipe de salida sirve para leer los mensajes de la consola
'El pipe de entrada sirve para mandar mensajes a la consola
'El pipe de entrada se crea solo si se habilita la interacción con el usuario
'Si no existe pipe de entrada, el programa de cmd finaliza si pide una respuesta al usuario, por ejemplo si pide autorización de sobreescritura de archivos
'Los pipes anónimos trabajan de forma sincrónica, esto significa que las apis esperan a que las operaciones de lectura/escritura se completen
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
'------------------------------
'ReadFile Permite leer información de la consola
'Si el programa de cmd no ha escrito ningún mensaje, esta función espera a que lo haga
'Si ocurre algún error ó el programa de cmd finaliza, esta función retorna 0
'De la misma forma, el programa de cmd espera a que se lea el mensaje pausando todas sus operaciones
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
'------------------------------
'CreateProcess Ejecuta el programa de cmd
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, 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
'------------------------------
'CloseHandle Cierra los handles de los pipes, hilos y procesos creados
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'------------------------------
'SetWindowText Permite mostrar la salida de consola en un textbox sin importar la longitud del texto
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
'------------------------------
'GetExitCodeProcess Permite obtener el codigo de salida del programa de consola
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
'------------------------------
'TerminateProcess Permite forzar el cierre del programa de cmd
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
'------------------------------
'WriteFile Permite escribir un mensaje para mandárselo al programa de cmd
'Esta API solo es utilizada si se habilita la interacción con el usuario
'La función retorna hasta que se escriben todo el mensaje en el pipe
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
'------------------------------
'PeekNamedPipe Permite saber si el programa de cmd escribió algún mensaje ó habrá que esperar a que lo haga
'Esta función compensa la limitación del API ReadFile con pipes anónimos, evitando que la aplicación se congele cuando el programa cmd demora demasiado en escribir un mensaje en el pipe
'Si la consola está esperando por una respuesta del usuario, esta función permite que la aplicación no se quede colgada
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
'------------------------------
'SuspendThread Permite pausar el proceso
Private Declare Function SuspendThread Lib "kernel32" (ByVal hThread As Long) As Long
'------------------------------
'ResumeThread Permite continuar el proceso pausado
Private Declare Function ResumeThread Lib "kernel32" (ByVal hThread As Long) As Long
'------------------------------
'Funciones API para ejecutar hilo
'Crea el hilo
Private Declare Function CreateThread Lib "kernel32.dll" (ByRef lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByRef lpParameter As Any, ByVal dwCreationFlags As Long, ByRef lpThreadId As Long) As Long
'Manipular los mensajes sin necesidad de las funciones de visual basic (incompatibles con el uso de hilo)
'Crear un TLS para el hilo
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 'CopyMemory No puede declararse como Function, de ser así el programa finaliza inesperadamente
'Acceder al puntero de una matriz buffer que guarda la cadena de texto
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (var() As Any) As Long
'Crear TLS para el hilo
Private Declare Function TlsAlloc Lib "kernel32.dll" () As Long
Private Declare Function TlsGetValue Lib "kernel32.dll" (ByVal dwTlsIndex As Long) As Long
Private Declare Function TlsSetValue Lib "kernel32.dll" (ByVal dwTlsIndex As Long, ByRef lpTlsValue As Any) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
'Enviar señal Ctrl-C a la consola
Private Declare Function AttachConsole Lib "kernel32.dll" (ByVal dwProcessId As Long) As Long
Private Declare Function FreeConsole Lib "kernel32.dll" () As Long
Private Declare Function SetConsoleCtrlHandler Lib "kernel32.dll" (ByVal HandlerRoutinePtr As Long, ByVal Add As Boolean) As Long
Private Declare Function GenerateConsoleCtrlEvent Lib "kernel32" (ByVal dwCtrlEvent As Long, ByVal dwProcessGroupId As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Variables para mandar mensajes a la consola ó saber el estado del proceso
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'ProcStatus permite manipular el proceso y obtener información acerca de su estado
'0 -> ningun proceso en ejecucion
'1 -> proceso esta ejecutandose
'2 -> esperando a que el programa cmd escriba un mensaje
'3 -> se esta forzando el cierre del proceso
'4 -> se está mandando un mensaje de texto a la consola
'6 -> el proceso está pausado
'7 -> reanudando proceso
Private ProcStatus As Byte
Private SendMsgBuffer As String 'Guarda el mensaje que será enviado a la consola
Private IDProceso As Long 'El id del proceso en ejecución (0 si no se está ejecutando nada)

'Variables para poder manejar el thread
Private CmdL As String
Private StartDir As String
Private SendMsgEnable As Byte
Private TextCtrl As TextBox
Private AutoScroll As Boolean
Private MsgShowMode As Byte
Private MaxLenBufferStdOut As Long
Private BufferStdOutPtr As Long
Private BufferExitCode As Long
Private EACThreadRet As Boolean
Private MemAddress As Long, TlsIndex As Long
Private TimerID As Long

Public Function ExecAndCapture(ByRef CmdLV As String, _
                                Optional ByRef StartDirV As String = vbNullString, _
                                Optional ByRef SendMsgEnableV As Byte = 0, _
                                Optional ByRef EnableWait4MsgV As Byte = 0, _
                                Optional TextCtrlV As TextBox, _
                                Optional ByRef AutoscrollV As Boolean = True, _
                                Optional ByRef MsgShowModeV As Byte = 0, _
                                Optional ByRef BufferStdOutV As String, _
                                Optional ByRef MaxLenBufferStdOutV As Long = -1, _
                                Optional ByRef BufferExitCodeV As Long) As Boolean
'Ejecuta un programa de linea de comandos. Devuelve True si el procedimiento finalizo con exito,
'False si ocurrio algun error
'Dependiendo de la configuración el programa de cmd se utiliza o no un hilo para el procedimiento
'de lectura de la consola
'   La funcion debe llamarse de la forma
'       Call ExeAndCapture(...
'   ó de la forma
'       Retorno=ExeAndCapture(...
'   Nunca de la forma
'       ExeAndCapture Arg1,Arg2...
'   Esto para hacer que los cambios en las variables "ByRef" se guarden
'CmdL: la linea de comandos a ejecutar
'StartDir: Ruta de directorio de inicio, no debe estar entrecomillada
'SendMsgEnable: Permite habilitar ó deshabilitar la interacción del usuario con la consola
'   1: habilita el envío de mensaje a la consola
'   0: deshabilita en envío de mensajes a la consola
'EnableWait4Msg: Habilita/deshabilita la espera por un mensaje del programa de cmd
'   no aplica cuando se utiliza un hilo para leer la consola
'   1: habilita
'   0: deshabilita
'   Si se habilita la interacción con el usuario, el valor que le de a este parámetro se ignora y cambia a 1
'   Si no se va a interactuar con el usuario:
'       a) cambie este valor a 1 si el programa de cmd tarda demasiado en escribir mensajes en la consola, esto evita que su aplicación se congele
'       b) cambie este valor a 0 si el programa de cmd refresca constantemente el buffer de mensajes. Esto aumentará la velocidad del proceso
'TextCtrl: Control TextBox en donde se mostraran los mensajes
'   Si TextCtrl no es multilinea los caracteres de salto de linea se eliminan
'MsgShowMode: Modo de mostrar mensajes en TextBox
'   0: no mostrar mensajes
'   1: mostrar todos los mensajes
'   2: mostrar solo el ultimo mensaje
'   3: mostrar solo el ultimo mensaje,  no mostrar mensajes vacios
'BufferStdOut: variable en donde se almacena la salida de consola
'MaxLenBufferStdOut: máxima longitud de la variable BufferStdOut
'   Si es menor a 0: se almacenan todos los mensajes
'   Si es igual a 0: no se almacena ningun mensaje
'   Si es mayor a 0: se almacenan solo los caracteres de los ultimos mensajes que "quepan" en el buffer
'BufferExitCode: Variable en donde se almacena el valor del codigo devuelto cuando el proceso termina

If Form1.Conv_Opt_EnableThreading.Checked = True Then
    'Crear un "Thread Local Storage" (TLS) para el hilo
    Dim Loc(40) As Byte, St As String
    Dim Add As Long, Hnd As Long, i As Integer, j As Integer
    Dim TlsAddress As Long
    Hnd = LoadLibrary("MSVBVM60.dll")
    Add = GetProcAddress(Hnd, "__vbaSetSystemError")
    CopyMemory Loc(0), ByVal (Add), 40
    While Loc(i) <> &HC3
        If Loc(i) = &HFF And Loc(i + 1) = &H35 Then
            For j = i + 2 To i + 5
                St = Hex(Loc(j)) & St
            Next
            TlsAddress = Val("&H" & St)
        End If
        i = i + 1
    Wend
    Call FreeLibrary(Hnd)
    MemAddress = 0
    If TlsAddress > 0 Then
        Call CopyMemory(TlsIndex, ByVal TlsAddress, Len(TlsIndex))
        MemAddress = TlsGetValue(TlsIndex)
    End If
    If MemAddress = 0 Then
        BufferStdOutV = "Error getting TLS index"
        Exit Function
    End If
    'Copia Valores
    CmdL = CmdLV
    StartDir = StartDirV
    SendMsgEnable = SendMsgEnableV
    Set TextCtrl = TextCtrlV
    AutoScroll = AutoscrollV
    MsgShowMode = MsgShowModeV
    MaxLenBufferStdOut = MaxLenBufferStdOutV
    BufferStdOutV = vbNullString
    'Obtiene los punteros de las variables ByRef
    BufferStdOutPtr = VarPtr(BufferStdOutV)
    Dim hThread As Long, Param As Long, saLC As SECURITY_ATTRIBUTES
    ProcStatus = 1
    saLC.nLength = Len(saLC)
    hThread = CreateThread(saLC, ByVal 0&, AddressOf ExecAndCaptureEnHilo, 0&, 0&, 0&)       'Ejecuta el programa e inicia la captura en un hilo
    While ProcStatus <> 0: DoEvents: Wend 'Espera a que el programa finalice
    Call CloseHandle(hThread)
    CmdL = vbNullString
    StartDir = vbNullString
    Set TextCtrl = Nothing
    BufferExitCodeV = BufferExitCode
    ExecAndCapture = EACThreadRet
    BufferStdOutPtr = 0
Else
    ExecAndCapture = ExecAndCaptureNoThreading(CmdLV, StartDirV, SendMsgEnableV, EnableWait4MsgV, TextCtrlV, AutoscrollV, MsgShowModeV, BufferStdOutV, MaxLenBufferStdOutV, BufferExitCodeV)
End If
IDProceso = 0
End Function

Private Sub ExecAndCaptureEnHilo()
Call TlsSetValue(TlsIndex, ByVal MemAddress)
Call ExecAndCaptureThreading
End Sub

Private Function ExecAndCaptureNoThreading(ByVal CmdL As String, _
                        Optional ByVal StartDir As String = vbNullString, _
                        Optional ByVal SendMsgEnable As Byte = 0, _
                        Optional ByVal EnableWait4Msg As Byte = 0, _
                        Optional TextCtrl As TextBox, _
                        Optional AutoScroll As Boolean = True, _
                        Optional MsgShowMode As Byte = 0, _
                        Optional ByRef BufferStdOut As String, _
                        Optional MaxLenBufferStdOut As Long = -1, _
                        Optional ByRef BufferExitCode As Long) As Boolean

Dim hPipeRead1 As Long 'handle para leer el mensaje de consola
Dim hPipeWrite1 As Long 'handle para que el programa de cmd escriba el mensaje
Dim hPipeRead2 As Long 'handle para que el programa de cmd lea nuestro mensaje
Dim hPipeWrite2 As Long 'handle para escribibir un mensaje y mandárselo al programa de cmd
Dim Buffer(BufferReadSize) As Byte 'Buffer de bytes en dónde se copia el mensaje leído de la consola
Dim LastMsg As String 'Guarda el último mensaje de consola
Dim sa As SECURITY_ATTRIBUTES, si As STARTUPINFO, pi As PROCESS_INFORMATION 'Estructuras necesarias para iniciar el prceso
Dim lBytesRead As Long 'Guarda la cantidad de bytes que se leyeron de la consola
Dim lBytesWritten As Long 'Guarda la cantidad de bytes que se escribieron en la consola
Dim lpTotalBytesAvail As Long 'Guarda la cantidad de bytes disponibles para leer de la consola, también sirve para detener el proceso cuando ya no hay más que leer

'Limpiar todas las variables ByRef y controles
BufferStdOut = vbNullString
BufferExitCode = 0
ProcStatus = 0
SendMsgBuffer = vbNullString
If MsgShowMode <> 0 Then TextCtrl.Text = vbNullString

'Crear los pipes
sa.nLength = Len(sa)
sa.bInheritHandle = 1
If CreatePipe(hPipeRead1, hPipeWrite1, sa, 0) = 0 Then Exit Function 'Pipes para lectura
If SendMsgEnable = 1 Then
EnableWait4Msg = 1 'Habilita la espera de mensajes
If CreatePipe(hPipeRead2, hPipeWrite2, sa, 0) = 0 Then Exit Function 'Pipes para escritura
End If

'Crear el proceso
si.cb = Len(si)
si.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
si.wShowWindow = SW_HIDE
si.hStdOutput = hPipeWrite1
si.hStdError = hPipeWrite1
If SendMsgEnable = 1 Then si.hStdInput = hPipeRead2
If CreateProcess(ByVal vbNullString, ByVal CmdL, ByVal 0&, ByVal 0&, 1, 0&, ByVal 0&, ByVal StartDir, si, pi) <> 1 Then GoTo FunctionTerminate
IDProceso = pi.dwProcessId
Call GetExitCodeProcess(pi.hProcess, BufferExitCode)
ProcStatus = 1

'Finaliza los handles que no serán utilizados por este programa
Call CloseHandle(hPipeWrite1)
Call CloseHandle(hPipeRead2)
'Call CloseHandle(pi.hThread)
hPipeWrite1 = 0
hPipeRead2 = 0

ProcStatus = 1
On Error Resume Next 'AutoScroll provoca error si la longitud del texto es excesiva
Do
DoEvents

'Esperar a que el programa cmd arroje un mensaje
If EnableWait4Msg = 1 Then
If ProcStatus = 1 Then ProcStatus = 2 'estado del proceso cambia a "esperando mensaje de consola"
lpTotalBytesAvail = 0
While lpTotalBytesAvail = 0 And ProcStatus = 2
DoEvents
If PeekNamedPipe(hPipeRead1, Null, 0&, 0&, lpTotalBytesAvail, 0&) = 0 Then lpTotalBytesAvail = -1
Wend
If lpTotalBytesAvail = -1 Then Exit Do
End If

If ProcStatus > 2 Then GoTo EnviarOrden 'El usuario envió una orden a la consola
ProcStatus = 1 'estado del proceso cambia a "en ejecución"

'Leer mensaje
If ReadFile(hPipeRead1, Buffer(0), BufferReadSize, lBytesRead, ByVal 0&) = 0 Then Exit Do
LastMsg = Left$(StrConv(Buffer(), vbUnicode), lBytesRead) 'Convertir a string
LastMsg = QuitCharNoPrint(LastMsg) 'quitar los caracteres no imprimibles del mensaje

If MaxLenBufferStdOut <> 0 Then 'Anexar al mensaje a BufferStdOut
BufferStdOut = BufferStdOut & LastMsg
If MaxLenBufferStdOut > 0 Then
If Len(BufferStdOut) > MaxLenBufferStdOut Then BufferStdOut = Right(BufferStdOut, MaxLenBufferStdOut)
End If
End If

'Mostrar mensaje en textbox
If MsgShowMode <> 0 Then
Select Case MsgShowMode
Case Is = 1: Call SetWindowText(TextCtrl.hWnd, TextCtrl.Text & LastMsg)
Case Is = 2: Call SetWindowText(TextCtrl.hWnd, QuitarEspaciosFinales(LastMsg))
Case Is = 3: If Replace(Replace(Replace(LastMsg, Chr(9), ""), Chr(10), ""), Chr(13), "") <> "" Then Call SetWindowText(TextCtrl.hWnd, QuitarEspaciosFinales(LastMsg))
End Select
If TextCtrl.MultiLine = False Then TextCtrl.Text = Replace(TextCtrl.Text, vbCrLf, "")
If AutoScroll = True Then TextCtrl.SelStart = Len(TextCtrl.Text)
End If

'Enviar una orden a la consola
EnviarOrden:
If ProcStatus > 2 Then
Select Case ProcStatus
'Case Is = 3 'Forzar el cierre del programa
'If TerminateProcess(ByVal pi.hProcess, ByVal 0&) <> 0 Then Exit Do Else ProcStatus = 1
Case Is = 4 'Mandar texto a la consola
If SendMsgEnable = 1 Then Call WriteFile(hPipeWrite2, ByVal SendMsgBuffer, Len(SendMsgBuffer), lBytesWritten, ByVal 0&)
SendMsgBuffer = vbNullString
ProcStatus = 1
Case Is = 6 'Pausar el proceso
If SuspendThread(pi.hThread) = -1 Then ProcStatus = 1 Else While ProcStatus = 6: DoEvents: Wend
Case Is = 7 'Reanudar proceso
If ResumeThread(pi.hThread) = -1 Then ProcStatus = 6 Else ProcStatus = 1
End Select
End If
Loop

Call CloseHandle(pi.hThread)
'Obtener el código de salida del programa cmd
Call GetExitCodeProcess(pi.hProcess, BufferExitCode)
Call CloseHandle(pi.hProcess)

ExecAndCaptureNoThreading = True
FunctionTerminate:
Call CloseHandle(hPipeRead1)
Call CloseHandle(hPipeWrite1)
Call CloseHandle(hPipeRead2)
Call CloseHandle(hPipeWrite2)
ProcStatus = 0
SendMsgBuffer = vbNullString
End Function

Private Sub ExecAndCaptureThreading()

Dim hPipeRead1 As Long 'handle para leer el mensaje de consola
Dim hPipeWrite1 As Long 'handle para que el programa de cmd escriba el mensaje
Dim hPipeRead2 As Long 'handle para que el programa de cmd lea nuestro mensaje
Dim hPipeWrite2 As Long 'handle para escribibir un mensaje y mandárselo al programa de cmd
Dim Buffer(BufferReadSize) As Byte 'Buffer de bytes en dónde se copia el mensaje leído de la consola
Dim LastMsgB() As Integer 'Buffer de bytes para formatear el último mensaje de consola
Dim LastMsg2 As String 'Variable puente para manipular a LastMsgB como string, su puntero es sobreescrito
Dim LastMsg As String 'Guarda el último mensaje de consola
Dim LastMsgPtr As Long 'El puntero de LastMsg2
Dim LastMsgBPtr As Long 'El puntero a los datos de LastMsgB
Dim LenLastMsg As Long 'Longitud en caraceteres del último mensaje
Dim LenBufferStdOut As Long 'Longitud de BufferStdOut
Dim sa As SECURITY_ATTRIBUTES, si As STARTUPINFO, pi As PROCESS_INFORMATION 'Estructuras necesarias para iniciar el prceso
Dim lBytesRead As Long 'Guarda la cantidad de bytes que se leyeron de la consola
Dim lBytesWritten As Long 'Guarda la cantidad de bytes que se escribieron en la consola
Dim BufferStdOut As String 'Variable (local) donde se guardarán todos los mensajes de salida
Dim BufferSOPtr As Long 'El puntero de bufferstdout, dicha posición de memoria será escrita con 0 para desvincular la cadena de caracteres a la variable local
Dim BufferSOSPtr As Long 'El puntero a los datos de bufferstdout será asignado al final del procedimiento a BufferStdOut (global) para que la cadena sea retornada
Dim i As Long, j As Long, k As Long 'contadores, variables auxiliares

BufferExitCode = 0
SendMsgBuffer = vbNullString
If MsgShowMode <> 0 Then TextCtrl.Text = vbNullString

'Prepara el buffer para guardar y formatear el último mensaje de consola
LastMsgPtr = VarPtr(LastMsg2)
ReDim LastMsgB(2 * BufferReadSize + 3)
LastMsgBPtr = VarPtrArray(LastMsgB())
Call CopyMemory(LastMsgBPtr, ByVal LastMsgBPtr, ByVal 4&)    'Obtiene el puntero del safe array
Call CopyMemory(LastMsgBPtr, ByVal LastMsgBPtr + 12&, ByVal 4&) 'Obtiene el puntero a los datos del safe array
'Cambia el puntero de la variable LastMsg2 para que apunte a los datos guardados
'en la matriz LastMsgB()
Call CopyMemory(ByVal LastMsgPtr, LastMsgBPtr + 4&, ByVal 4&)

'Crear los pipes
sa.nLength = Len(sa)
sa.bInheritHandle = 1
If CreatePipe(hPipeRead1, hPipeWrite1, sa, 0) = 0 Then GoTo FunctionTerminate
If SendMsgEnable = 1 Then
    If CreatePipe(hPipeRead2, hPipeWrite2, sa, 0) = 0 Then GoTo FunctionTerminate
End If

'Crear el proceso
si.cb = Len(si)
si.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
si.wShowWindow = SW_HIDE
si.hStdOutput = hPipeWrite1
si.hStdError = hPipeWrite1
If SendMsgEnable = 1 Then si.hStdInput = hPipeRead2
If CreateProcess(ByVal vbNullString, ByVal CmdL, ByVal 0&, ByVal 0&, 1, 0&, ByVal 0&, ByVal StartDir, si, pi) <> 1 Then GoTo FunctionTerminate
IDProceso = pi.dwProcessId
Call GetExitCodeProcess(pi.hProcess, BufferExitCode)

'Finaliza los handles que no serán utilizados por este programa
Call CloseHandle(hPipeWrite1)
Call CloseHandle(hPipeRead2)
'Call CloseHandle(pi.hThread)
hPipeWrite1 = 0
hPipeRead2 = 0

On Error Resume Next 'AutoScroll provoca error si la longitud del texto es excesiva
Do

If ProcStatus > 2 Then GoTo EnviarOrden 'El usuario envió una orden a la consola

'Leer mensaje
If ReadFile(hPipeRead1, Buffer(0), BufferReadSize, lBytesRead, ByVal 0&) = 0 Then Exit Do

'Convierte el mensaje a UNICODE. Elimina los caracteres no imprimibles
'y formatea los saltos de línea
j = 2
For i = 0 To lBytesRead - 1
    If Buffer(i) = 9 Or Buffer(i) = 10 Or Buffer(i) = 13 Or Buffer(i) = 128 Or Buffer(i) = 145 Or Buffer(i) = 146 Or (Buffer(i) > 31 And Buffer(i) < 127) Or Buffer(i) > 159 Then
        Select Case Buffer(i)
            Case Is = 10
                Call CopyMemory(LastMsgB(j), 655373, ByVal 4&)
                j = j + 2
            Case Is = 13
                Call CopyMemory(LastMsgB(j), 655373, ByVal 4&)
                If lBytesRead - 1 > i Then: If Buffer(i + 1) = 10 Then i = i + 1
                j = j + 2
            Case Else
                LastMsgB(j) = Buffer(i)
                j = j + 1
        End Select
    End If
Next

If j > 2 Then
    'Agregar el caracter nulo de terminación
    LastMsgB(j) = 0
    'Calcula la longitud de cadena en caracteres
    LenLastMsg = j - 2
    'Agrega el indicador de longitud de cadena (en bytes)
    Call CopyMemory(LastMsgB(0), LenLastMsg * 2, ByVal 4&)
    LastMsg = LastMsg2 'La cadena contenida en la matriz LastMsgB debe pasarse a una cadena estandar para que no provoque error
Else
    LastMsg = "" 'ningún caracter imprimible en la cadena
    LenLastMsg = 0
End If

'Anexar el mensaje a BufferStdOut
If MaxLenBufferStdOut <> 0 And LenLastMsg > 0 Then 'Anexar al mensaje a BufferStdOut
    If MaxLenBufferStdOut < 0 Then
        'No hay límite para tamaño de buffer, solo concatenar
        BufferStdOut = BufferStdOut & LastMsg
    Else
        'Hay límite para el tamaño de buffer
        LenBufferStdOut = Len(BufferStdOut)
        If LenBufferStdOut + LenLastMsg > MaxLenBufferStdOut Then 'Anexar el último mensaje superaría el tamaño máximo
            If LenBufferStdOut < MaxLenBufferStdOut Then 'Bufferstdout aún no alcanza el máximo tamaño
                Select Case LenLastMsg
                    Case Is < MaxLenBufferStdOut
                        'caracteres que deben sobreescribirse en bufferstdout para que quepa Lastmsg
                        i = LenBufferStdOut + LenLastMsg - MaxLenBufferStdOut
                        'Puntero de bufferstdout
                        j = StrPtr(BufferStdOut)
                        'Mueve los caracteres del final de bufferstdout para hacer espacio a lastmsg
                        Call CopyMemory(ByVal j, ByVal j + i * 2, ByVal (LenBufferStdOut - i) * 2)
                        'Copia los primeros caracteres de LastMsg al final de bufferstdout
                        Call CopyMemory(ByVal j + (LenBufferStdOut - i - 1) * 2, LastMsgB(2), i * 2)
                        'Mueve los caracteres restantes de lastmsg al principio de la cadena
                        Call CopyMemory(LastMsgB(2), LastMsgB(2 + i), ByVal (LenLastMsg - i) * 2)
                        LastMsgB(LenLastMsg - i + 3) = 0 'caracter nulo de fin de cadena
                        'Escribe la nueva longitud de lastmsg
                        Call CopyMemory(LastMsgB(0), (LenLastMsg - i) * 2, ByVal 4&)
                        'Concatena las 2 cadenas
                        BufferStdOut = BufferStdOut & LastMsg2
                    Case Is = MaxLenBufferStdOut: BufferStdOut = LastMsg
                    Case Is > MaxLenBufferStdOut 'La longitud del último mensaje es mayor a la máxima permitida -> escribir solo los caracteres que quepan del último mensaje
                        Call CopyMemory(LastMsgB(2), LastMsgB(2 + LenLastMsg - MaxLenBufferStdOut), ByVal MaxLenBufferStdOut + 1)
                        Call CopyMemory(LastMsgB(0), MaxLenBufferStdOut * 2, ByVal 4&)
                        BufferStdOut = LastMsg2
                End Select
            Else 'BufferStdOut alcanzó su tamaño máximo
                'los espacios en caracteres que dejaría disponibles el último mensaje
                i = MaxLenBufferStdOut - LenLastMsg
                Select Case i
                    'El último mensaje supera la longitud máxima permitida
                    'Escribe solo los últimos caracteres del mensaje que quepan en el buffer
                    Case Is < 0: Call CopyMemory(ByVal StrPtr(BufferStdOut), ByVal StrPtr(LastMsg) - i * 2, ByVal MaxLenBufferStdOut * 2)
                    'El último mensaje justamente tiene la longitud máxima permitida
                    Case Is = 0: BufferStdOut = LastMsg
                    'El último mensaje tiene una longitud menor a la máxima permitida
                    'Mueve los útlimos caracteres de bufferstdout al inicio de la cadena
                    'para hacerle espacio al último mensaje, entonces lo escribe
                    Case Is > 0
                        Call CopyMemory(ByVal StrPtr(BufferStdOut), ByVal StrPtr(BufferStdOut) + 2 * LenLastMsg, ByVal 2 * i)
                        Call CopyMemory(ByVal StrPtr(BufferStdOut), ByVal StrPtr(BufferStdOut) + 2 * i, ByVal LenLastMsg * 2)
                End Select
            End If
        Else 'Anexar el último mensaje no supera la longitud máxima -> solo concatenar los strings
            BufferStdOut = BufferStdOut & LastMsg
        End If
    End If
End If

'Mostrar mensaje en textbox
If MsgShowMode <> 0 Then
    If TextCtrl.MultiLine = False And LenLastMsg > 0 Then
    '    'quita los caracteres de salto de línea si el textbox no es multilínea
        Call CopyMemory(LastMsgB(2), ByVal StrPtr(LastMsg), ByVal LenLastMsg * 2)
        LastMsgB(2 + LenLastMsg) = 0
        i = 0
        While i <= LenLastMsg - 2
            Call CopyMemory(j, LastMsgB(2 + i), ByVal 4&)
            If j = 655373 Then
                j = (LenLastMsg - i) * 2 - 4
                Call CopyMemory(LastMsgB(2 + i), LastMsgB(4 + i), ByVal j)
                LenLastMsg = LenLastMsg - 2
            Else
                i = i + 1
            End If
        Wend
        If LenLastMsg = 0 Then
            LastMsg = ""
        Else
            Call CopyMemory(LastMsgB(0), LenLastMsg * 2&, ByVal 4&)
            LastMsgB(2 + LenLastMsg) = 0
            LastMsg = LastMsg2
        End If
    End If
    If MsgShowMode > 1 And LenLastMsg > 0 Then
        'quita caracteres en blanco del inicio y fin de la cadena
        Call CopyMemory(LastMsgB(2), ByVal StrPtr(LastMsg), ByVal LenLastMsg * 2)
        While (LastMsgB(2) = 9 Or LastMsgB(2) = 10 Or LastMsgB(2) = 13 Or LastMsgB(2) = 32) And LenLastMsg > 0
            Call CopyMemory(LastMsgB(2), LastMsgB(3), ByVal (LenLastMsg - 1) * 2)
            LenLastMsg = LenLastMsg - 1
        Wend
        While (LastMsgB(LenLastMsg + 1) = 9 Or LastMsgB(LenLastMsg + 1) = 10 Or LastMsgB(LenLastMsg + 1) = 13 Or LastMsgB(LenLastMsg + 1) = 32) And LenLastMsg > 0: LenLastMsg = LenLastMsg - 1: Wend
        If LenLastMsg = 0 Then
            LastMsg = ""
        Else
            LastMsgB(LenLastMsg + 2) = 0
            Call CopyMemory(LastMsgB(0), LenLastMsg * 2&, ByVal 4&)
            LastMsg = LastMsg2
        End If
    End If
    Select Case MsgShowMode
        'anexa el último mensaje al textbox
        Case Is = 1: If LenLastMsg > 0 Then Call SetWindowText(TextCtrl.hWnd, TextCtrl.Text & LastMsg)
        'muestra el último mensaje en el textbox
        Case Is = 2: Call SetWindowText(TextCtrl.hWnd, LastMsg)
        Case Is = 3
            Call CopyMemory(LastMsgB(0), ByVal StrPtr(LastMsg), ByVal LenLastMsg * 2)
            i = 0
            While i < LenLastMsg
                'busca caracteres que no estén en blanco y si encuentra uno imprime el mensaje
                If LastMsgB(i) <> 9 And LastMsgB(i) <> 10 And LastMsgB(i) <> 13 And LastMsgB(i) <> 32 Then
                    Call SetWindowText(TextCtrl.hWnd, LastMsg)
                    i = LenLastMsg
                End If
                i = i + 1
            Wend
    End Select
If AutoScroll = True Then TextCtrl.SelStart = Len(TextCtrl.Text)
End If

'Enviar una orden a la consola
EnviarOrden:
If ProcStatus > 2 Then
    Select Case ProcStatus
    'Case Is = 3 'Forzar el cierre del programa
    'If TerminateProcess(ByVal pi.hProcess, ByVal 0&) <> 0 Then Exit Do Else ProcStatus = 1
    Case Is = 4 'Mandar texto a la consola
    If SendMsgEnable = 1 Then Call WriteFile(hPipeWrite2, ByVal SendMsgBuffer, Len(SendMsgBuffer), lBytesWritten, ByVal 0&)
    SendMsgBuffer = vbNullString
    ProcStatus = 1
    Case Is = 6 'Pausar el proceso
    If SuspendThread(pi.hThread) = -1 Then ProcStatus = 1 Else While ProcStatus = 6: DoEvents: Wend
    Case Is = 7 'Reanudar proceso
    If ResumeThread(pi.hThread) = -1 Then ProcStatus = 6 Else ProcStatus = 1
    End Select
End If
Loop

Call CloseHandle(pi.hThread)
'Obtener el código de salida del programa cmd
Call GetExitCodeProcess(pi.hProcess, BufferExitCode)
Call CloseHandle(pi.hProcess)

EACThreadRet = True

FunctionTerminate:
Call CloseHandle(hPipeRead1)
Call CloseHandle(hPipeWrite1)
Call CloseHandle(hPipeRead2)
Call CloseHandle(hPipeWrite2)
SendMsgBuffer = vbNullString

'Retorna los mensajes de salida de consola
If BufferStdOut <> vbNullString Then
    BufferSOPtr = VarPtr(BufferStdOut)
    BufferSOSPtr = StrPtr(BufferStdOut)
    Call CopyMemory(ByVal BufferStdOutPtr, BufferSOSPtr, ByVal 4&)
    Call CopyMemory(ByVal BufferSOPtr, 0&, ByVal 4&)
End If

'Restaura el puntero de la variable string puente LastMsg2 para que pueda ser eliminada correctamente
Call CopyMemory(ByVal LastMsgPtr, 0&, ByVal 4&)

ProcStatus = 0
End Sub

Public Function ProcessStatus() As Byte
ProcessStatus = ProcStatus
End Function

Public Sub StopProcess()
If ProcStatus = 0 Then Exit Sub
Call APIS.MatarProcesoPorID(IDProceso)
End Sub

Public Sub SendMsgToConsole(Mensaje As String, Optional EnviarEnter As Boolean = True)
If ProcStatus <> 0 And ProcStatus <> 6 And ProcStatus <> 7 Then 'Los mensajes no se envían si el proceso está pausado
If EnviarEnter Then SendMsgBuffer = Mensaje & vbCrLf Else SendMsgBuffer = Mensaje
ProcStatus = 4
End If
End Sub

Public Sub PauseProcess()
If ProcStatus <> 0 Then ProcStatus = 6
End Sub

Public Sub ContinueProcess()
If ProcStatus <> 0 Then ProcStatus = 7
End Sub

'FUNCIONES PARA MANEJO DE CADENAS DE TEXTO

Public Function QuitarEspaciosFinales(Cadena As String) As String
On Error GoTo ErrH
Dim Ret As String, i As Long
Ret = Cadena
While (Left(Ret, 1) = Chr(9) Or Left(Ret, 1) = Chr(10) Or Left(Ret, 1) = Chr(13) Or Left(Ret, 1) = " ") And Ret <> "": Ret = Right(Ret, Len(Ret) - 1): Wend
While (Right(Ret, 1) = Chr(9) Or Right(Ret, 1) = Chr(10) Or Right(Ret, 1) = Chr(13) Or Right(Ret, 1) = " "): Ret = Left(Ret, Len(Ret) - 1): Wend
QuitarEspaciosFinales = Ret
Exit Function
ErrH:
QuitarEspaciosFinales = Cadena
End Function

Public Function QuitCharNoPrint(Cadena As String) As String
'Quita los caracteres "no imprimibles"
'que un control textbox muestra como un cuadro, barra ó simbolo
'exceptuando las tabulaciones y las cadenas "Retorno de carro+Nueva linea"
Dim Ret As String, i As Long
Ret = Cadena
For i = 0 To 31
If i <> 9 And i <> 10 And i <> 13 Then Ret = Replace(Ret, Chr(i), "")
Next
Ret = Replace(Ret, Chr(10), Chr(13))
Ret = Replace(Ret, Chr(13), vbCrLf)
Ret = Replace(Ret, vbCrLf & vbCrLf, vbCrLf)
For i = 129 To 144: Ret = Replace(Ret, Chr(i), ""): Next
For i = 147 To 159: Ret = Replace(Ret, Chr(i), ""): Next
Ret = Replace(Ret, Chr(127), "")
QuitCharNoPrint = Ret
End Function

Public Function IDProcesoPrincipal() As Long
'Devuelve el ID del proceso principal que se está ejecutando
'No devuelve: los ID de los subprocesos iniciados por el proceso principal
'Devuelve 0 cuando no se está ejecutando nada
IDProcesoPrincipal = IDProceso
End Function

Public Sub SendCtrlC()
If IDProceso = 0 Then Exit Sub
If AttachConsole(IDProceso) <> 0 Then 'Adjunta el proceso de consola a la consola de la aplicación
    Call SetConsoleCtrlHandler(ByVal 0&, ByVal True) 'Deshabilita Ctrl+C para la aplicación
    Call GenerateConsoleCtrlEvent(ByVal CTRL_C_EVENT, ByVal 0&) 'Envia la señal Ctrl+C a consola
    Call FreeConsole 'Desadjunta el proceso de consola a la consola de la aplicación
    'Esperar 2 segundos para habilitar ctrl+c en la aplicación
    TimerID = SetTimer(ByVal 0&, ByVal 0&, ByVal 2000&, AddressOf TimerProc)
    While TimerID <> 0: DoEvents: Wend
    Call SetConsoleCtrlHandler(ByVal 0&, ByVal False)
End If
End Sub

Private Sub TimerProc()
Call KillTimer(ByVal 0&, TimerID)
TimerID = 0
End Sub
