RESPUESTA A LA PREGUNTA 5429 - VISUAL BASIC


debes crear un nuevo proyecto, el form debe tener un textbox y command button.


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 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 WaitForSingleObject Lib "kernel32" _
    (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
   hObject As Long) As Long
   Const SW_SHOWMINNOACTIVE = 7
   Const STARTF_USESHOWWINDOW = &H1
   Const INFINITE = -1&
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const STARTF_USESTDHANDLES = &H100&
Private Function ExecCmdPipe(ByVal CmdLine As String) As String
    'Ejecuta el comando indicado, espera a que termine
    'y redirige la salida hacia VB
    Dim proc As PROCESS_INFORMATION, ret As Long, bSuccess As Long
    Dim start As STARTUPINFO
    Dim sa As SECURITY_ATTRIBUTES
    Dim hReadPipe As Long, hWritePipe As Long
    Dim bytesread As Long, mybuff As String
    Dim i As Integer
    Dim sReturnStr As String        '=== Longitud de la cadena, en teoría 64 KB,
    '   pero no en la práctica    'mybuff = String(64 * 1024, Chr$(65))    '
    mybuff = String(10 * 1024, Chr$(65))
    sa.nLength = Len(sa)
    sa.bInheritHandle = 1&
    sa.lpSecurityDescriptor = 0&
    ret = CreatePipe(hReadPipe, hWritePipe, sa, 0)
    If ret = 0 Then
        '===Error
        ExecCmd = "Error: CreatePipe failed. " & Err.LastDllError
        Exit Function
    End If
    start.cb = Len(start)
    start.hStdOutput = hWritePipe
    start.dwFlags = STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW
    start.wShowWindow = SW_SHOWMINNOACTIVE
    ' Start the shelled application:
    ret& = CreateProcessA(0&, CmdLine$, sa, sa, 1&, _
        NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
    If ret <> 1 Then
        '===Error
        sReturnStr = "Error: CreateProcess failed. " & Err.LastDllError
    End If        ' Wait for the shelled application to finish:
    ret = WaitForSingleObject(proc.hProcess, INFINITE)
    'En el original, sólo leian 100 caracteres
    bSuccess = ReadFile(hReadPipe, mybuff, Len(mybuff), bytesread, 0&)
    If bSuccess = 1 Then
    sReturnStr = Left(mybuff, bytesread)
    Else
        '===Error
       sReturnStr = "Error: ReadFile failed. " & Err.LastDllError
    End If
    ret = CloseHandle(proc.hProcess)
    ret = CloseHandle(proc.hThread)
    ret = CloseHandle(hReadPipe)
    ExecCmdPipe = sReturnStr
End Function
Private Sub Command1_Click()
    Text1.Text = ExecCmdPipe("ping 192.1.1.1")
End Sub
Private Sub Form_Load()    '
   ' Text1 = ""    '    Show
    'Asigna al TextBox lo que se introduzca en la línea de comandos
   Text1.Text = ExecCmdPipe("ping 192.1.1.1")
   Text1.Refresh
End Sub

Si necesitas te puedo enviar el ejemplo a tu correo.


Daniel Francisco Figueoa Aguirre
d_figueroa@yupimail.com