VBNet - Форум - Чтение консоли VB6

Вопрос: Чтение консоли VB6 Добавлено: 18.09.09 14:07

Автор вопроса: J. Smith | Web-сайт: Не хочу ломать голову, если её уже сломал кто-то другой. | ICQ: ненавижу

[SOURCE]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 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 Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
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 String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) 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 Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, ByVal lpBuffer As String, ByVal nBufferSize As Long, lpBytesRead As Long, lpTotalBytesAvail As Long, lpBytesLeftThisMessage 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 Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Const DUPLICATE_SAME_ACCESS As Long = 2&
Private Const ERROR_BROKEN_PIPE As Long = 109&
Private Const ERROR_NO_DATA As Long = 232&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000&
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const STARTF_USESTDHANDLES As Long = &H100&
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, ByVal lpSource As String, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByVal Arguments As Long) As Long

Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Dim hShell As Long, hOutputRead As Long
Dim ShellRes As String

Private Sub Form_Initialize()
Call InitCommonControlsXP
End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
'If KeyAscii = 13 Then KeyAscii = 0: Text2.Enabled = False: Text1.Text = DOS2ANSI(SysShell(Text2.Text, Text3.Text)): Text2.Enabled = True
If KeyAscii = 13 Then KeyAscii = 0: Text2.Enabled = False: Text1.Text = SysShell(Text2.Text, Text3.Text): Text2.Enabled = True
End Sub

Private Sub tmrTimeOut_Timer()
Kill
End Sub

Public Function ANSI2DOS(Src As Variant) As String
Src = CStr(Src)
ANSI2DOS = Space$(Len(Src))
CharToOem Src, ANSI2DOS
End Function

Public Function DOS2ANSI(Src As Variant) As String
Src = CStr(Src)
DOS2ANSI = Space$(Len(Src))
OemToChar Src, DOS2ANSI
End Function

Public Function SysShell(CmdLine As Variant, Optional Interval As Variant) As String
Dim hOutputReadTmp As Long, hOutputWrite As Long
Dim hErrorWrite As Long
Dim tmpStr As String
Dim sa As SECURITY_ATTRIBUTES
Dim pi As PROCESS_INFORMATION
Dim si As STARTUPINFO

    ShellRes = Empty
    CmdLine = CStr(CmdLine)
    tmrTimeOut.Interval = CInt(Interval)
    tmrTimeOut.Enabled = True

    With sa
        .nLength = Len(sa)
' .lpSecurityDescriptor = 0
        .bInheritHandle = 1
    End With

    If CreatePipe(hOutputReadTmp, hOutputWrite, sa, 0) = 0 Then ErrorMessage ("CreatePipe")
' Necessary in case the child application closes one of its std output handles.
    If DuplicateHandle(GetCurrentProcess, hOutputWrite, GetCurrentProcess, hErrorWrite, 0, 1, DUPLICATE_SAME_ACCESS) = 0 Then ErrorMessage ("DuplicateHandle")

' Otherwise, the child inherits the handles and, as a result, non-closeable handles are created.
    If DuplicateHandle(GetCurrentProcess, hOutputReadTmp, GetCurrentProcess, hOutputRead, 0, 0, DUPLICATE_SAME_ACCESS) = 0 Then ErrorMessage ("DupliateHandle")
    If CloseHandle(hOutputReadTmp) = 0 Then ErrorMessage ("CloseHandle")

    With si
        .cb = Len(si)
        .dwFlags = STARTF_USESTDHANDLES ' Or STARTF_USESHOWWINDOW
        .hStdOutput = hOutputWrite
        .hStdError = hErrorWrite
        .wShowWindow = 1 'vbNormal
    End With
    If CreateProcess(vbNullString, CmdLine, 0, 0, 1, 0, 0, vbNullString, si, pi) = 0 Then ErrorMessage ("CreateProcess")
    hShell = pi.hProcess
    If CloseHandle(pi.hThread) = 0 Then ErrorMessage ("CloseHandle")

' You need to make sure that no handles to the write end of the output pipe are maintained in this process
' or else the pipe will not close when the child process exits and the ReadFile will hang.
    If CloseHandle(hOutputWrite) = 0 Then ErrorMessage ("CloseHandle")
    If CloseHandle(hErrorWrite) = 0 Then ErrorMessage ("CloseHandle")

    With tmrRedirect
        .Enabled = True
        While .Enabled
            DoEvents
        Wend
    End With

    SysShell = ShellRes
End Function

Private Sub Kill()
    tmrRedirect.Enabled = False
    tmrTimeOut.Enabled = False
    TerminateProcess hShell, 0
    If CloseHandle(hShell) = 0 Then ErrorMessage ("CloseHandle")
    If CloseHandle(hOutputRead) = 0 Then ErrorMessage ("CloseHandle")
End Sub

Private Sub tmrRedirect_Timer()
Dim lpBuffer As String
Dim tmpStr As String
Dim nBytesRead As Long
    If PeekNamedPipe(hOutputRead, vbNullString, 0, 0, nBytesRead, 0) = 0 Then
        If Err.LastDllError = ERROR_BROKEN_PIPE Then
' Child has closed
            Kill
        Else
            ErrorMessage ("PeekNamedPipe")
        End If
    ElseIf nBytesRead > 0 Then
        lpBuffer = Space(nBytesRead)
        If ReadFile(hOutputRead, lpBuffer, Len(lpBuffer), nBytesRead, 0) = 0 Then
            ErrorMessage ("ReadFile")
        Else
            If nBytesRead > 0 Then
                lpBuffer = Replace(lpBuffer, Chr$(10), vbCrLf)
                ShellRes = ShellRes & lpBuffer
            End If
        End If
    End If
End Sub

Private Sub ErrorMessage(pszAPI As String)
Dim szPrintBuffer As String * 512

Call FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0, Err.LastDllError, 0, szPrintBuffer, Len(szPrintBuffer), 0)
If Len(ShellRes) > 0 Then ShellRes = ShellRes & vbCrLf
ShellRes = ShellRes & "Calling: " & pszAPI & vbCrLf & _
                      "Message: " & szPrintBuffer
End Sub[/SOURCE]
Этот код почему-то возвращает ответ не всех консольных прог.
Пару лет назад написал прогу, всё работало, исходники посеял, а недавно антивиры нашли таки мой бэкдор, взялся переписывать и вот такая проблема...
Ответить

Ответы Всего ответов: 6

Номер ответа: 1 Автор ответа: J. Smith ICQ: ненавижу Вопросов: 40 Ответов: 477	Web-сайт: Не хочу ломать голову, если её уже сломал кто-то другой. Профиль \| \| #1	Добавлено: 18.09.09 14:11
	Offtop: Не понял почему тэг не сработал Ответить

Номер ответа: 2 Автор ответа: Artyom Разработчик Вопросов: 130 Ответов: 6602	Профиль \| \| #2	Добавлено: 18.09.09 20:47
	Могу сказать что теряешь время. Потому что никто не найдет и не будет искать ошибку в полуторах сотнях строк чужого кода, не имея информации под какими версиями каких операционных систем с какими программами происходят ошибки. Ответить

Номер ответа: 3 Автор ответа: Smith ICQ: adamis@list.ru Вопросов: 153 Ответов: 3632	Профиль \| \| #3	Добавлено: 19.09.09 16:36
	Не теряю, разобрался уже. Ответить

Номер ответа: 4 Автор ответа: Smith ICQ: adamis@list.ru Вопросов: 153 Ответов: 3632	Профиль \| \| #4	Добавлено: 19.09.09 17:38
	Что никто не найдет это верно, но думаю дело вовсе не в наличии/отсутствии исчерпывающей инфы. Если кто заинтересовался этим кодом ПРЕДУПРЕЖДАЮ он работает только с консольными прогами написанными на vb6! С прогами винды ошибок никаких не происходит, просто код не возвращает текст с консоли. Ответить

Номер ответа: 5 Автор ответа: Winand Вопросов: 87 Ответов: 2795	Web-сайт: winandfx.narod.ru Профиль \| \| #5	Добавлено: 19.09.09 17:51
	А как на VB6 писать консольные проги? Ответить

Номер ответа: 6 Автор ответа: Smith ICQ: adamis@list.ru Вопросов: 153 Ответов: 3632	Профиль \| \| #6	Добавлено: 19.09.09 20:02
	Ты знаешь оказывается элементарно, товаришь Nir Sofer давно разобрался в этом вопросе http://nirsoft.mirrorz.com Еси нужны могу кинуть пару исходничков своих утилиток. Ответить

Страница: 1 |