The following is my code I made, -------------------------------------------------------------------------------------------------------------------------------------------------------------- ---------- Module code -------------------------------------- -------- Attribute VB_Name = "DosIo" 'private data structure declaration private Type STARTUPINFO' (createprocess) 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 LongEnd TypePrivate Declare Function FlushFileBuffers Lib "kernel32" (ByVal hFile As Long) As LongPrivate Declare Function OpenProcess LIB "kernel32" (byval dwdesiredaccess as long, byval binherithandle as long) As long
Private Type PROCESS_INFORMATION '(creteprocess) hProcess As Long hThread As Long dwProcessId As Long dwThreadID As LongEnd TypePrivate Type SECURITY_ATTRIBUTES' (createprocess) nLength As Long lpSecurityDescriptor As Long bInheritHandle As LongEnd Type 'constant declarations Private Const NORMAL_PRIORITY_CLASS = & H20 & Private Const STARTF_USESTDHANDLES = & H100 & Private Const STARTF_USESHOWWINDOW = & H1Private PROCESS_TERMINATE = & H1Private PROCESS_QUERY_INFORMATION = & 'function declaration H400 Const Const Private declare function CreateProcessA Lib "kernel32" (_ ByVal lpApplicationName As Long, _ ByVal lpCommandLine As String, _ lpProcessAttributes As SECURITY_ATTRIBUTES, _ lpThreadAttributes As SECURITY_ATTRIBUTES, _ ByVal bInheritHandles As Long, _ ByVal dwCreationFlags As Long, _ ByVal lpEnvironment As Long, _ ByVal lpCurrentDirectory As Long, _ lpStartupInfo As STARTUPINFO, _ lpProcessInformation As PROCESS_INFORMATION) As LongPrivate Declare Function GetCurrentProces s Lib "kernel32" () As LongPrivate Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As LongPrivate Declare Function PeekNamedPipe Lib "kernel32" _ (ByVal hNamedPipe As Long, _ ByVal lpBuffer As Long, _ BYVAL NBUFFERSIZE AS Long, _ byref lptotalbytesavail as long
Private Declare Function CreatePipe Lib "kernel32" (_ phReadPipe As Long, _ phWritePipe As Long, _ lpPipeAttributes As Any, _ ByVal nSize As Long) As LongPrivate Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As LongPrivate Declare Function ReadFile Lib "kernel32" (_ ByVal hFile As Long, _ ByVal lpBuffer As Long, _ ByVal nNumberOfBytesToRead As Long, _ lpNumberOfBytesRead As Long, _ ByVal lpOverlapped As Any) As LongPrivate Declare Function CloseHandle Lib "kernel32" (_ ByVal hHandle As Long) As LongPrivate Declare Function GetLastError Lib "kernel32" () As LongPrivate Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, _ ByVal lpBuffer As Long, _ ByVal nNumberOfBytesToWrite As Long, _ ByRef lpNumberOfBytesWritten As Long, _ LPOVERLAPPED AS ANY) As Long
Private Declare Function DuplicateHandle Lib "kernel32" _ (ByVal hSourceProcessHandle As Long, _ ByVal hSourceHandle As Long, _ ByVal hTargetProcessHandle As Long, _ lpTargetHandle As Long, _ ByVal dwDesiredAccess As Long, _ ByVal bInheritHandle As Long, _ ByVal dwOptions As Long) As long
Private Const DUPLICATE_SAME_ACCESS = & H2Private PipeR4InputChannel As Long, PipeW4InputChannel As Long, hInputHandle As LongPrivate PipeR4OutputChannel As Long, PipeW4OutputChannel As Long, hOutputHandle As LongPrivate Proc As PROCESS_INFORMATIONPublic Enum InitResult ERROR_OK 0 ERROR_INIT_INPUT_HANDLE = 1 ERROR_INIT_OUTPUT_HANDLE = 2 ERROR_DUP_READ_HANDLE = 3 ERROR_DUP_WRITE_HANDLE = 4 ERROR_CREATE_CHILD_PROCESS = 5End = EnumPublic Enum TermResult ERROR_OK = 0End EnumPublic Enum InputResult ERROR_OK = 0 ERROR_QUERY_WRITE_INFO_SIZE = 1 ERROR_DATA_TO_LARGE = 2 ERROR_WRITE_INFO = 3 ERROR_WRITE_UNEXPECTED = 5End EnumPublic Enum OutputResult ERROR_OK = 0 ERROR_QUERY_READ_INFO_SIZE = 1 ERROR_ZERO_INFO_SIZE = 2 ERROR_READ_INFO = 3 ERROR_UNEQUAL_INFO_SIZE = 4 ERROR_READ_UNEXPECTED = 5End EnumPublic Function InitDosIO () AS INITRESULT DIM SA As Security_Attributes, Ret As Long with sa .nlength = len (sa) .binherithandle = 1 & .LPSecurityDescriptor = 0 & End with Ret = CreatePipe (PipeR4InputChannel, PipeW4InputChannel, Sa, 1024 &) If Ret = 0 Then 'establishment procedure supply line InitDosIO = ERROR_INIT_INPUT_HANDLE Exit Function End If Ret = CreatePipe (PipeR4OutputChannel, PipeW4OutputChannel, Sa, 4096 &)' create output channel, if the establishment fails, Turn off the pipe, exit if return = 0 Then 'Establishing the output pipeline CloseHandle PiPer4InputChannel CloseHandle Pipew4inputChannel Initdosio = Error_init_output_handle exit function end if
Ret = DuplicateHandle (GetCurrentProcess (), PipeW4InputChannel, GetCurrentProcess (), hInputHandle, 0, True, DUPLICATE_SAME_ACCESS) If Ret = 0 Then 'converts write handle CloseHandle PipeR4InputChannel CloseHandle PipeW4InputChannel CloseHandle PipeR4OutputChannel CloseHandle PipeW4OutputChannel InitDosIO = ERROR_DUP_WRITE_HANDLE Exit Function End If Ret = CloseHandle ( PipeW4InputChannel) If Ret = 0 Then MsgBox "close handle eerr" End If Ret = DuplicateHandle (GetCurrentProcess (), PipeR4OutputChannel, GetCurrentProcess (), hOutputHandle, 0, True, DUPLICATE_SAME_ACCESS) If Ret = 0 Then 'convert read handle CloseHandle PipeR4InputChannel CloseHandle PipeW4InputChannel CloseHandle PipeR4OutputChannel CloseHandle PipeW4OutputChannel InitDosIO = ERROR_DUP_READ_HANDLE Exit Function End If Ret = CloseHandle (PipeR4OutputChannel) If Ret = 0 Then MsgBox "close handle 2 er" End If Dim Start As STARTUPINFO, CmdStr As String Start.cb = Len (Start) Star t.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW Start.hStdOutput = PipeW4OutputChannel Start.hStdError = PipeW4OutputChannel Start.hStdInput = PipeR4InputChannel CmdStr = "CMD" Ret & = CreateProcessA (0 &, CmdStr, Sa, Sa, True, NORMAL_PRIORITY_CLASS, 0 &, 0 &, Start, Proc ) Iferandle pipew4inputchannel closehandle pipew4outputchannel closehandle pipew4outputchannel initdosio =
ERROR_CREATE_CHILD_PROCESS Exit Function End If End FunctionPublic Function DosInput (ByVal Str As String) As InputResult Dim Btarray As String, Buflen As Long, BtWritten As Long, Rtn As Long Dim BtTest () As Byte Btarray = StrConv (Str vbCrLf, vbFromUnicode) BtTest = StrConv (Str vbCrLf, vbFromUnicode) buflen = LenB (Btarray) Rtn = WriteFile (hInputHandle, StrPtr (BtTest), buflen, BtWritten, ByVal 0 &) If BtWritten = 0 Then DosInput = ERROR_WRITE_INFO Exit Function End If DosInput = 0End Function
Public Function DosOutput (ByRef StrOutput As String) As OutputResult Dim Ret As Long, TmpBuf As String * 128, BtRead As Long, BtTotal As Long, BtLeft As Long Rtn = PeekNamedPipe (hOutputHandle, StrPtr (TmpBuf), 128, BtRead, BtTotal, BtLeft) If Rtn = 0 then 'informative queries DosOutput = ERROR_QUERY_INFO_SIZE exit Function End If If BtTotal = 0 then' if the information is empty, exit DosOutput = ERROR_ZERO_INFO_SIZE exit Function End If Dim Btbuf () as Byte, BtReaded as Long ReDim Btbuf (BtTotal) Ret = ReadFile (hOutputHandle, VarPtr (Btbuf (0)), BtTotal, lngbytesread, 0 &) If Ret = 0 Then DosOutput = ERROR_READ_INFO Exit Function End If If BtTotal <> lngbytesread Then DosOutput = ERROR_UNEQUAL_INFO_SIZE End If Dim strBuf As String strBuf = StrConv (Btbuf, vbUnicode) Debug.Print strBuf strOutput = strBufEnd FunctionPublic Function EndDosIo () As Long Dim Ret As Long CloseHandle PipeR4InputChannel CloseHandle PipeW4InputChannel CloseHandle PipeR4OutputChannel CloseHandle PipeW4OutputChanne l CloseHandle Proc.hthread CloseHandle Proc.hprocessif EndProcess (Proc.dwprocessid) = false The msgbox "Main Server [cmd.exe] is not closed, please close", vbinformation, "Sorry" end ifnd function
Public Function EndProcess (ByVal ProcessID As Long) As Boolean Dim hProcess As Long, ExitCode As Long, Rst As Long hProcess = OpenProcess (PROCESS_TERMINATE Or PROCESS_QUERY_INFORMATION, True, ProcessID) If hProcess <> 0 Then GetExitCodeProcess hProcess, ExitCode If ExitCode <> 0 Then Rst = TerminateProcess (hProcess, ExitCode) CloseHandle hProcess If Rst = 0 Then EndProcess = False Else EndProcess = True End If Else EndProcess = False End If Else EndProcess = False End If End Function ----------- ------------------------------------------- Form code ---- ----------------------------------- Version 5.00BEGIN VB.FORM FORM1 BORDERSTYLE = 1 'fixed Single Caption = "Console Pipe Redirection" ClientHeight = 4620 Clientleft = 45 Clienttop = 330 ClientWidth = 8820 Linktopic = "Form1" MaxButton = 0 'False ScaleHeight = 4620 Scalewidth = 8820 S tartUpPosition = 3 'Windows Default Begin VB.CommandButton cmdget Caption = "get console output character" BeginProperty Font Name = "Arial" Size = 9.75 Charset = 0 Weight = 700 Underline = 0' False Italic = 0 'False Strikethrough = 0' False endproperty Height = 360 left = 1830 TabINDEX = 4 TOP = 4245 width =
4575 End Begin VB.CommandButton cmdExe Caption = "command to write the console" BeginProperty Font Name = "Arial" Size = 9 Charset = 134 Weight = 700 Underline = 0 'False Italic = 0' False Strikethrough = 0 'False EndProperty Height = 375 Left = 6720 TabIndex = 3 Top = 105 Width = 1800 End Begin VB.TextBox txtOutput BackColor = & H00404040 & BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0' False StrikeTHROUGH = 0 'false endproperty forecolor = & h80000005 & height = 3615 left = 0 locked = -1 'True MultiLine = -1' True ScrollBars = 2 'Vertical TabIndex = 2 Top = 540 Width = 8775 End Begin VB.TextBox TxtExecute BackColor = & H00404040 & BeginProperty Font Name = "MS Sans Serif" Size = 9.75 Charset = 0 Weight = 400 Underline = 0 'false italic = 0'
False Strikethrough = 0 'False EndProperty ForeColor = & H00FFFFFF & Height = 375 Left = 1320 TabIndex = 0 Top = 120 Width = 5295 End Begin VB.Label Label1 Caption = "command input:" BeginProperty Font Name = "MS Sans Serif" Size = 9.75 charset = 0 Weight = 700 Underline = 0 'False Italic = 0' False Strikethrough = 0 'False EndProperty Height = 375 Left = 120 TabIndex = 1 Top = 120 Width = 855 EndEndAttribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PREDECLAREDID = TRUEATTRIBUTE VB_EXPOSED = falseprivate sub cmdexe_click () DIM RET AS long, streecute.text if What is the command of the command? " Errors, Vbinformation, "Error" EXIT SUB End If SW Falseend Sub
Private Sub Cmdget_Click () DIM STRR AS STRING RET = DOSOUTPUT (STR) IF RET = 0 TXTOUTPUT.TEXT = STRR ELSE MSGBOX "Read Console Output Error", Vbinformation, "Error" end if sw talkeend SUB
Private Sub Form_Load () Dim Ret As Long Ret = InitDosIO () If Ret <> 0 Then MsgBox "console input and output pipes redirected initialization failed" End End If sw TrueEnd SubPrivate Sub Form_Unload (Cancel As Integer) EndDosIoEnd SubPrivate Sub sw ( Byval s as boolean) cmdexe.enabled = s cmdget.enabled = not send Sub Running Platform: 2000 / XP / slight modification can be used for 98
