Работа с консолью из VB6

@Антихакер32 · Регистрация: 06.01.2014

Студворк — интернет-сервис помощи студентам

Вот модуль класса, который я смонтировал,
черпая инфу из самых разнообразных источников...
который запускает консоль и даёт возможность вставлять туда свой текст...

Используется так...

Visual Basic
1
2
3
4
5
6
7
Sub main()
    Dim cons As New Console
'    ConsoleWriteLine "Привет пиплы :)"
    cons.ConsoleWriteLine "Echo on"
    cons.ConsoleWriteLine "regsvr32 dllERR.dll"
    Debug.Print cons.ConsoleReadLine
End Sub

теперь вопросы...

Как заставить такую консоль реально выполнять комманды ?
почему, не функционирует ReadLine ?.. собственно из за нее и делаю...
как настроить параметр запуск в скрытом режиме... ?
можно ли какнибудь подменить используемые хендлы, на Хэндл Shell("cmd.exe")

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Option Explicit
'
'© FelixMacintosh 2014
'Работа с консолью с возможностью ввода/вывода русских символов
'
Private Const FOREGROUND_BLUE = &H1
Private Const FOREGROUND_GREEN = &H2
Private Const FOREGROUND_RED = &H4
Private Const BACKGROUND_BLUE = &H10
Private Const BACKGROUND_GREEN = &H20
Private Const BACKGROUND_RED = &H40
Private Const BACKGROUND_INTENSITY = &H80&
Private Const BACKGROUND_SEARCH = &H20&
Private Const FOREGROUND_INTENSITY = &H8&
Private Const FOREGROUND_SEARCH = (&H10&)
Private Const ENABLE_LINE_INPUT = &H2&
Private Const ENABLE_ECHO_INPUT = &H4&
Private Const ENABLE_MOUSE_INPUT = &H10&
Private Const ENABLE_PROCESSED_INPUT = &H1&
Private Const ENABLE_WINDOW_INPUT = &H8&
Private Const ENABLE_PROCESSED_OUTPUT = &H1&
Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2&
Private Const STD_OUTPUT_HANDLE = -11&
Private Const STD_INPUT_HANDLE = -10&
Private Const STD_ERROR_HANDLE = -12&
Private Const INVALID_HANDLE_VALUE = -1&
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function WriteConsole Lib "kernel32" Alias "WriteConsoleA" (ByVal hConsoleOutput As Long, lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) 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
 
Private hConsoleOut As Long, hConsoleIn As Long, hConsoleErr As Long
 
Private Sub Class_Initialize()
    If AllocConsole() Then
        hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE)
        If hConsoleOut = INVALID_HANDLE_VALUE Then MsgBox "Не удается получить STDOUT"
        hConsoleIn = GetStdHandle(STD_INPUT_HANDLE)
        If hConsoleOut = INVALID_HANDLE_VALUE Then MsgBox "Не удается получить STDIN"
    Else
        MsgBox "Невозможно запустить вторую копию консоли"
    End If
    'Установить заголовок окна консоли
    SetConsoleTitle App.EXEName & "Copyright (c) FelixMacintosh 2014"
    'Задать синий фона текста в консоли с ярко-желтыми символами
    SetConsoleTextAttribute hConsoleOut, FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_INTENSITY _
    Or BACKGROUND_BLUE
End Sub
 
Private Sub Class_Terminate()
    'Delete console
    CloseHandle hConsoleOut
    CloseHandle hConsoleIn
    FreeConsole
End Sub
 
Private Function DOSToWin(sourstr$) As String
    DOSToWin = Space$(Len(sourstr))
    OemToChar sourstr, DOSToWin
End Function
 
Private Function WinToDOS(sourstr$) As String
    WinToDOS = Space$(Len(sourstr))
    CharToOem sourstr, WinToDOS
End Function
 
 
 
 
Public Sub ConsoleWriteLine(sInput As String)
    ConsoleWrite sInput & vbCrLf
End Sub
 
Public Sub ConsoleWrite(sInput As String)
    Dim cWritten As Long
    WriteConsole hConsoleOut, ByVal WinToDOS(sInput), Len(sInput), cWritten, ByVal 0&
End Sub
 
Public Function ConsoleReadLine() As String
    Dim ZeroPos As Long
    'Create a buffer
    ConsoleReadLine = String(255, 0)
    'Read the input
    ReadConsole hConsoleIn, ConsoleReadLine, Len(ConsoleReadLine), vbNull, vbNull
    'Strip off trailing vbCrLf and Chr$(0)'s
    ZeroPos = InStr(ConsoleReadLine, Chr$(0))
    If ZeroPos > 0 Then ConsoleReadLine = DOSToWin(Left$(ConsoleReadLine, ZeroPos - 3))
End Function

Добавлено через 1 час 34 минуты
...и тишина....
все молчат, тогда так, какой тут код поставить чтоб
взвамодействовать с окном консоли, причем в скрытом режиме
пробывал через SendKeys, компьютер виснет приходилось из розетки выключать
2 попытки уже сделал

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Dim hProc&, hShell&, Path34$, n&
 
Sub main()
    'hShell = Shell("cmd.exe", 0) 'Скрытый режим !
    MsgBox "для выхода можно ввести ""Exit""" & " и Enter"
    hShell = Shell("cmd.exe", 1)
    hProc = OpenProcess(&H100000, False, hShell)
    While WaitForSingleObject(hProc, 100)
        '
        'Что требуется здесь вписать чтоб передать консоле инфу..
        'и получить ответ...
        'С условием что консоль будет скрыта ???
        '
        Debug.Print n: n = n + 1
    Wend
    CloseHandle hProc
 
End Sub

@Антихакер32 · 19.05.2014, 22:05 **[ТС]**

ладно ... попытаюсь какнибудь разобраться...
...да уж... тяжелый случай, там скорей всего в кодировках дело..
а какие там кодировки используют специалисты той ветки ?
..наверное придёться вникнуть...

Добавлено через 2 часа 48 минут
всё исправил !

Добавлено через 3 минуты
Здесь не нужно своей интерпритации ...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Public Sub SendToShell(ByVal CommandLine As String, Optional bNewLine As Boolean)
 
    Dim BytesWritten As Long
    If hInput = 0 Then Exit Sub
    CommandLine = Trim(CommandLine)
    '
    'Моя интерпритация, для синхронности с консолью....
    'Подразумеваеться, что синтаксис CMD будет правильным
    '
    If InStr(1, CommandLine, "Cls", vbTextCompare) Like "[1-2]" And Len(CommandLine) < 5 Then
        Command1_Click
    End If
    '
    '
    '
    CharToOem CommandLine, CommandLine
    
    If bNewLine Then CommandLine = CommandLine & vbCrLf
    If WriteFile(hInput, ByVal CommandLine, Len(CommandLine), BytesWritten, 0&) = 0 Then
        Exit Sub
    Else
        Call GetOutTextShell(sOut)
    End If
 
End Sub

а только следить чтоб консоль была открыта или закрыта...

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Public Function GetOutTextShell(CommandLine As String) As Boolean
    Dim bBuffer() As Byte, f&, inst&
    Dim lLen As Long
    Dim bRes As Boolean
    Dim lLenBuff As Long
    For f = 1 To 100 '100 попыток ...
        DoEvents 'Включить реакцию чтоб не зависла
        Do
            bRes = CBool(PeekNamedPipe(hOutput, 0&, 0&, 0&, lLen, 0&))
            If Not bRes Then Exit Do
            If lLen <= 0 Then Exit Do
            ReDim bBuffer(lLen)
            
            If ReadFile(hOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&) = 0 Then Exit Do
        
            CommandLine = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
            OemToChar CommandLine, CommandLine
            
            If bOnlyOut Then
                inst = InStr(1, CommandLine, vbCrLf) + 2
                CommandLine = Mid$(CommandLine, IIf(inst = 2, 1, inst))
            End If
            Exit For
        Loop
        Sleep 100 'Ждать когда появится запись
    Next
    GetOutTextShell = True
    If CommandLine = "" Then
        '
        'Вылез пустой ответ
        'Проверка что консоль работает ! и уйти если хендл не отвечает
        '
        If WaitForSingleObject(hCmd, 100) = 0 Then End
    End If
End Function

Добавлено через 2 минуты
протестил, теперь то что не работало, стало работать

...

Добавлено через 6 минут
а главное быстро...

@Антихакер32 · 19.05.2014, 22:18 **[ТС]**

и батник этот работает, а просил он этот файл ~dp0Elevating.vbs...
которого у меня в системе нет вообще

Bash
1
2
3
4
5
6
7
8
9
10
11
12
13
@echo off
if "%1"=="" (
  Echo CreateObject^("Shell.Application"^).ShellExecute WScript.Arguments^(0^),"1","","runas",1 >"%~dp0Elevating.vbs"
  cscript.exe //nologo "%~dp0Elevating.vbs" "%~dpnx0"& Goto :eof
)
>nul del "%~dp0Elevating.vbs"
chdir /d "%~dp0"
for /f "delims=" %%A in ('dir /b /s /a-d-L "%~dp0*.dll","%~dp0*.ocx"') do (
  Echo Регистрация %%A
  regsvr32.exe "%%A"
  rem regsvr32.exe /s "%%A"&Rem Silent-режим регистрации
)
pause

@Антихакер32 · 20.05.2014, 15:07 **[ТС]**

весь прикол в том..., что в моей, наспех собранной тестовой программке
работать намного удобнее чем в системной консоли...
я имею ввиду правку, и прочее...

хотя мне само окно и не нужно...

ладно... разберусь...

Добавлено через 14 часов 6 минут
вот оказывается где этот код был

... https://www.cyberforum.ru/blog... g1885.html

..я сейчас рассматриваю возможность исключить TextBox
и сообщения передовать в окно Immediate ...

а для этого опять таки обратился к твоему блогу.. https://www.cyberforum.ru/blog... g1943.html
чтоб осуществить передачу нажатых клавиш в работающее
приложение в режиме Debug.

Вот мой код, в еще более оптимизированном виде ...

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
#На форму необходимо закинуть TextBox с именем Text1 со свойством Multiline = True
 
Option Explicit
'
'    '© FelixMacintosh (CiberForum.ru)
'    'Интерактивная консоль
'
#Const DebugForm = 1
#Const DebugClass = 0
 
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
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
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
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
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) 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 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
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
 
'
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const DUPLICATE_SAME_ACCESS As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
'
Private Const TimeOut = 10
Private Const Max = 2 ^ 31 - 1
'
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 Type PROCESS_INFORMATION
    hProcess As Long
    hThread As Long
    dwProcessId As Long
    dwThreadId As Long
End Type
'Мои переменные
Dim hInput As Long
Dim hOutput As Long
Dim hCmd As Long
Dim sOut As String
Dim nOutLen As Long
Dim WithEvents cmm As CommandButton
 
 
Private Sub Form_Unload(Cancel As Integer)
    Call StopShell
End Sub
 
Private Sub Form_Resize()
    'Разместить форму по центру
    Me.Move (Screen.Width - Me.ScaleWidth) / 2, (Screen.Height - Me.ScaleHeight) / 2
End Sub
Private Sub Form_Load()
    Dim myHeight&
    Const cnsWidth = 11000
    Const cnsHeight = 4000
    Set cmm = Controls.Add("VB.CommandButton", "cmm")
    cmm.Caption = "Очистить"
    cmm.Visible = True
    Me.Width = cnsWidth
    Me.Height = cnsHeight
    myHeight& = Me.ScaleHeight - cmm.Height
    Text1.Move 0, 0, Me.ScaleWidth, myHeight&
    cmm.Move 0, myHeight&
    '---------------------
    Text1.ForeColor = Text1.BackColor
    Text1.BackColor = 0
    Me.Caption = App.EXEName
 
    StartShell
    SetText
End Sub
Private Sub Command1_Click()
    sOut = ""
    Text1.Text = ""
    SetText
End Sub
 
Private Sub Text1_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim f&, j$(), s$
 
    If KeyCode = 13 And Right$(Text1, 2) = vbCrLf Then
        KeyCode = 0
        s = Mid(Text1, nOutLen + 1)
        j = Split(s, vbCrLf)
 
        For f = 0 To UBound(j) - 1
            SendToShell j(f), True
            SetText
        Next
    End If
End Sub
Private Sub SetText()
    Text1 = Text1 & sOut
    nOutLen = Len(Text1)
    Text1.SelStart = nOutLen
End Sub
'=======================================================
'=======================================================
'=======================================================
'=======================================================
'=======================================================
'=======================================================
'=======================================================
'=======================================================
Public Sub SendToShell(ByVal CommandLine As String, Optional bCrLf As Boolean)
 
    Dim BytesWritten As Long
    If hInput = 0 Then Exit Sub
    '
    CommandLine = Trim(CommandLine)
    CharToOem CommandLine, CommandLine 'Перевод в DOS
    '
    If bCrLf Then CommandLine = CommandLine & vbCrLf
    If WriteFile(hInput, ByVal CommandLine, Len(CommandLine), BytesWritten, 0&) = 0 Then
        Exit Sub
    ElseIf GetOutTextShell(sOut) Then
        '
        If InStr(1, CommandLine, "Cls", vbTextCompare) Like "[1-2]" Then
            If Asc(sOut) = 12 Then Command1_Click 'Синхронизация с командой очистить
        End If
        '
    End If
 
End Sub
 
 
Public Function GetOutTextShell(CommandLine As String) As Boolean
    Dim bBuffer() As Byte, f&, inst&
    Dim lLen As Long
    Dim bRes As Boolean
    Dim lLenBuff As Long
 
    Do Until CBool(PeekNamedPipe(hOutput, 0&, 0&, 0&, lLen, 0&)) And lLen
        DoEvents 'Включить реакцию чтоб не зависла
        Sleep TimeOut 'Ждать когда появится запись
    Loop
    ReDim bBuffer(lLen)
    Call ReadFile(hOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&)
    CommandLine = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
    OemToChar CommandLine, CommandLine 'Перевод в Windows
    inst = InStr(1, CommandLine, vbCrLf) + 2 'Правая часть текста .. тоесть ответ
    CommandLine = Mid$(CommandLine, IIf(inst = 2, 1, inst))
    If CommandLine = "" Then
        '
        'Вылез пустой ввод и ответ
        'Проверка что консоль работает ! и уйти если хендл не отвечает
        '
        If WaitForSingleObject(hCmd, TimeOut) = 0 Then
            Call StopShell
            Exit Function
        End If
    End If
    GetOutTextShell = True
End Function
 
Public Sub StopShell()
    Call CloseHandle(hInput)
    Call CloseHandle(hOutput)
    Call TerminateProcess(hCmd, ByVal 0&)
    Call CloseHandle(hCmd)
    Call WaitForSingleObject(hCmd, -1&) 'Ждать пока не закроется
End Sub
 
Public Function StartShell() As Boolean
    On Error GoTo Error
    Dim tSecurityAttributes As SECURITY_ATTRIBUTES, f&
    Dim tStartInfo As STARTUPINFO
    Dim tProcessInfo As PROCESS_INFORMATION
    Dim lCurrentID As Long
    lCurrentID = GetCurrentProcess()
 
    With tStartInfo
        .cb = Len(tStartInfo)
        .dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
    End With
 
    With tSecurityAttributes
        .nLength = Len(tSecurityAttributes)
        .bInheritHandle = 1
    End With
 
    If CreatePipe(hOutput, tStartInfo.hStdOutput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If CreatePipe(tStartInfo.hStdInput, hInput, tSecurityAttributes, 0) = 0 Then
        GoTo Error
    End If
 
    If DuplicateHandle(lCurrentID, tStartInfo.hStdOutput, lCurrentID, tStartInfo.hStdError, _
    0&, True, DUPLICATE_SAME_ACCESS) = 0 Then
        GoTo Error
    End If
 
    If CreateProcess(vbNullString, "cmd", tSecurityAttributes, tSecurityAttributes, 1, NORMAL_PRIORITY_CLASS, _
    ByVal 0&, vbNullString, tStartInfo, tProcessInfo) = 0 Then
        GoTo Error
    End If
 
    With tProcessInfo
        Call CloseHandle(.hThread)
        hCmd = .hProcess
        If .dwProcessId > 0 And .hProcess > 0 Then
            StartShell = True
            If Not GetOutTextShell(sOut) Then GoTo Error 'Cтартовый текст
        Else
            GoTo Error
        End If
    End With
 
    Exit Function
Error:
    Call StopShell
End Function

а вот измененный модуль ..

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
Option Explicit
 
' Модуль для перехвата событий ввода мыши и клавиатуры
' © Кривоус Анатолий Анатольевич (The trick), 2014
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type MSLLHOOKSTRUCT
    pt As POINTAPI
    mouseData As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private Type KBDLLHOOKSTRUCT
    VkCode As Long
    ScanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
 
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
 
Private Const WH_KEYBOARD_LL = 13
Private Const WH_MOUSE_LL = &HE&
Private Const HC_ACTION = 0
Private Const LLKHF_INJECTED = &H10
Private Const LLMHF_INJECTED = 1
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSEWHEEL As Long = &H20A
 
Dim hKeyHook As Long, hMouseHook As Long
 
Public Sub Hook()
    hKeyHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelkbdProc, App.hInstance, 0)
    If hKeyHook = 0 Then MsgBox ("Keyboard hook error")
    hMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, App.hInstance, 0)
    If hMouseHook = 0 Then MsgBox ("Mouse hook error")
End Sub
Public Sub UnHook()
    If hKeyHook Then UnhookWindowsHookEx (hKeyHook): hKeyHook = 0
    If hMouseHook Then UnhookWindowsHookEx (hMouseHook): hMouseHook = 0
End Sub
' Процедура перехвата сообщений клавиатуры
Private Function LowLevelkbdProc(ByVal uCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
            Debug.Print KeyString(wParam) & _
                                      "KeyCode: " & lParam.VkCode & _
                                      " ScanCode: " & lParam.ScanCode & _
                                      IIf(lParam.flags And LLKHF_INJECTED, "(inj)", vbNullString)
        End Select
    End If
    LowLevelkbdProc = CallNextHookEx(hKeyHook, uCode, wParam, lParam)
End Function
' Процедура перехвата сообщений мыши
Private Function LowLevelMouseProc(ByVal uCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
    If uCode = HC_ACTION Then
        Select Case wParam
        Case WM_MOUSEMOVE
            Debug.Print "MouseMove: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
 
        Case WM_MOUSEWHEEL
            Debug.Print "MouseWheel: " & _
                                      "Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      " Dir: " & IIf(lParam.mouseData > 0, "Forward", "Backward") & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
 
        Case Else
            Debug.Print MouseString(wParam) & _
                                      " Coord: " & lParam.pt.x & ", " & lParam.pt.y & _
                                      IIf(lParam.flags And LLMHF_INJECTED, "(inj)", vbNullString)
 
        End Select
    End If
    LowLevelMouseProc = CallNextHookEx(hMouseHook, uCode, wParam, lParam)
End Function
Private Function MouseString(WH As Long) As String
    Select Case WH
    Case WM_LBUTTONDOWN: MouseString = "MouseLButtonDown:"
    Case WM_LBUTTONUP: MouseString = "MouseLButtonUp:"
    Case WM_RBUTTONDOWN: MouseString = "MouseRButtonDown:"
    Case WM_RBUTTONUP: MouseString = "MouseRButtonUp:"
    Case WM_MBUTTONDOWN: MouseString = "MouseMButtonDown:"
    Case WM_MBUTTONUP: MouseString = "MouseMMuttonUp:"
    End Select
End Function
Private Function KeyString(WH As Long) As String
    Select Case WH
    Case WM_KEYDOWN: KeyString = "KeyDown:"
    Case WM_KEYUP: KeyString = "KeyUp:"
    Case WM_SYSKEYDOWN: KeyString = "KeySysDown:"
    Case WM_SYSKEYUP: KeyString = "KeySysUp:"
    End Select
End Function

а можно какнибудь без хука обойтись ..

Добавлено через 5 минут
итог всех этих мучений предпологается такой..
будет только одна публичная функция ..

Visual Basic
1
2
вызываемая таким образом 
Console.InOut(LineIn as string) as string '... возвращающая ответ...

Добавлено через 14 минут
и при этом в окне immediate будет продублирован текст консоли
ведь всёравно же .. Debug.print не обрабатывается в откомпиленном коде
и нужен он мне будет только в режиме отладки

@The trick · 20.05.2014, 15:26

У тебя есть каналы для обмена, через них получай данные.

@Антихакер32 · 20.05.2014, 15:40 **[ТС]**

...думал не ответиш, я собственно решил
твоим кодом воспользоваться, ..сейчас отлаживаю чтоб возникал
правильный символ ...например если ранее был нажат Shift...

вообще код очень полезный, спасибо за него !

Добавлено через 2 минуты
подскажи только как можно быстро получить хендл окна immediate
и прочитать от туда последнюю строку, вообще такое сделать можно ? ...

@_r_m_b_ · 29.09.2016, 15:37

Приветствую Вас! Нашел тему, которая мне нужна. но реализовать замысел не получается. замысел такой: из под VB/VBA нужно запустить консольное приложение, посылать ему команды и читать результат выполнения последних. по выше приведенному примеру: открываю процесс для приложения. PIPE. пытаюсь считать-считывается информация о приложении. посылаю команду и пытаюсь считать результат - считывается такое же количество байт, что послал(колько в нечитабельном виде). результата нет. повторное считывание дает 0. такое ощущение, что посланная команда не отрабатывает. посмотреть что происходит в консоли нет возможности. помогите советом

Dragokas · 02.10.2016, 12:59

Где код?

@_r_m_b_ · 03.10.2016, 08:51

С проблемой разобрался, но возникла другая. посылаю команду приложению и пытаюсь считать данные. результат всегда разный. как организовать процесс, чтобы считывать данные полностью? чего только не делал: задержки, повторное считывание - ничего не получается. в режиме пошагового выполнения - все считывается нормально... всю голову сломал.

@fever brain · 03.10.2016, 10:24

Смотря какое приложение, и какой код возврата у этого приложения
в любом случае обычно при нормальном завершении код возврата =0

Добавлено через 6 минут
Да и вот еще что, если вы выкладываетево вложениях, то хотябы предупреждайте что там у вас
документ в формате .dcom который я незнаю и знать не хочу чем он запускается, здесь же раздел vb6 не нак-ли..

@_r_m_b_ · 03.10.2016, 12:36

файл ms word с поддержкой макросов. макросы написаны на VBA: такой же VB... очень жаль, что Вы не смогли помочь(даже не посмотрели какое приложение запускается). буду очень признателен, если кто-то откликнется

Dragokas · 03.10.2016, 20:49

_r_m_b_, поведение весьма ожидаемо, т.к. происходит рассинхронизация.
После передачи команды в консоль через канал атомарная операция завершается.
Дальше происходит параллельно и выполнение команды в CMD, и чтение первой порции данных, попадающих постепенно во входящий канал, как только CMD выводит очередную строку.

Здесь действительно пример кода не особо важен, больше теория.
Я подобными вещами не занимался, поэтому так чтобы наверняка ответ дать не могу.

Как это грамотно делать, вам может помочь человек, наверное кто занимался сетевыми технологиями, можно спросить например в разделе C++ и WinAPI.

От себя могу предложить:
1) если CMD нужен для выполнения только одной команды, можно вызвать его таким образом:

Visual Basic
1
Execute "c:\Windows\System32\cmd.exe /c dir c:"

После выполнения команды CMD завершится автоматически.
Следовательно, нужно добавить ожидание завершения процесса (GetExitCodeProcess будет != STILL_ALIVE).
Можно своей реализацией цикла с DoEvents + TimeOut или через WaitForSingleObject).
Тогда во входящий канал попадут все данные одной порцией.

2) Задать и ожидать уникальный идентифицирующий признак конца данных.
Например,

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private Sub main()
    Const Uniq_EOF$ = "#End-Of-Data#"
    Const TimeOut = 15000 '15 sec.
    Dim t&, s$, ss$, times&
    
    Execute "c:\Windows\System32\cmd.exe"
    WriteConsole "cd /d c:\"
    WriteConsole "dir"
    WriteConsole "dir /b /s c:\users\tfcor\desktop\NoSignProblem\BadCatRoot\*"
    WriteConsole "echo " & Uniq_EOF
    
    t = GetTickCount()
    Do
        DoEvents
        Sleep 200
        ReadConsole s
        ss = ss & s
        times = times + 1
    Loop Until (InStrRev(ss, Uniq_EOF) <> 0) Or ((GetTickCount() - t) > TimeOut)
    
    Debug.Print ss
    Debug.Print "Times ReadConsole executed: " & times
    Terminate
End Sub

Да, и я удалил

Visual Basic
1
Result = FlushFileBuffers(pipeIn.hWritePipe)

Это вызывало фриз программы.

@_r_m_b_ · 04.10.2016, 09:15

Dragokas, спасибо за отклик. попробую попросить подсказок в другой ветке. вариант с задержками не красив и его можно попробовать просто в качестве примера, но не решения. приложение cmd, приведено, тоже в качестве примера. на практике должно работать другое. если этот вариант не решится, то лучше вообще бросить эту затею.

Новые блоги и статьи Все статьи Все блоги /
Философия технологии iceja 01.02.2026 На мой взгляд у человека в технических проектах остается роль генерального директора. Все остальное нейронки делают уже лучше человека. Они не могут нести предпринимательские риски, не могут. . .	SDL3 для Web (WebAssembly): Вывод текста со шрифтом TTF с помощью SDL3_ttf 8Observer8 01.02.2026 Содержание блога В этой пошаговой инструкции создадим с нуля веб-приложение, которое выводит текст в окне браузера. Запустим на Android на локальном сервере. Загрузим Release на бесплатный. . .	SDL3 для Web (WebAssembly): Сборка C/C++ проекта из консоли 8Observer8 30.01.2026 Содержание блога Если вы откроете примеры для начинающих на официальном репозитории SDL3 в папке: examples, то вы увидите, что все примеры используют следующие четыре обязательные функции, а. . .	SDL3 для Web (WebAssembly): Установка Emscripten SDK (emsdk) и CMake для сборки C и C++ приложений в Wasm 8Observer8 30.01.2026 Содержание блога Для того чтобы скачать Emscripten SDK (emsdk) необходимо сначало скачать и уставить Git: Install for Windows. Следуйте стандартной процедуре установки Git через установщик. . . .
SDL3 для Android: Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 29.01.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами. Версия v3 была полностью переписана на Си, в. . .	Инструменты COM: Сохранение данный из VARIANT в файл и загрузка из файла в VARIANT bedvit 28.01.2026 Сохранение базовых типов COM и массивов (одномерных или двухмерных) любой вложенности (деревья) в файл, с возможностью выбора алгоритмов сжатия и шифрования. Часть библиотеки BedvitCOM Использованы. . .	SDL3 для Android: Загрузка PNG с альфа-каналом с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 28.01.2026 Содержание блога SDL3 имеет собственные средства для загрузки и отображения PNG-файлов с альфа-каналом и базовой работы с ними. В этой инструкции используется функция SDL_LoadPNG(), которая. . .	SDL3 для Android: Загрузка PNG с альфа-каналом с помощью SDL3_image 8Observer8 27.01.2026 Содержание блога SDL3_image - это библиотека для загрузки и работы с изображениями. Эта пошаговая инструкция покажет, как загрузить и вывести на экран смартфона картинку с альфа-каналом, то есть с. . .

@The trick Модератор 10048 / 3894 / 883 Регистрация: 22.02.2013 Сообщений: 5,847 Записей в блоге: 79
	20.05.2014, 15:26
	У тебя есть каналы для обмена, через них получай данные. 0

@Антихакер32 1201 / 473 / 46 Регистрация: 06.01.2014 Сообщений: 1,797 Записей в блоге: 19
	20.05.2014, 15:40 [ТС]
	...думал не ответиш, я собственно решил твоим кодом воспользоваться, ..сейчас отлаживаю чтоб возникал правильный символ ...например если ранее был нажат Shift... вообще код очень полезный, спасибо за него ! Добавлено через 2 минуты подскажи только как можно быстро получить хендл окна immediate и прочитать от туда последнюю строку, вообще такое сделать можно ? ... 0

@_r_m_b_ 0 / 0 / 0 Регистрация: 29.09.2016 Сообщений: 10
	29.09.2016, 15:37
	Приветствую Вас! Нашел тему, которая мне нужна. но реализовать замысел не получается. замысел такой: из под VB/VBA нужно запустить консольное приложение, посылать ему команды и читать результат выполнения последних. по выше приведенному примеру: открываю процесс для приложения. PIPE. пытаюсь считать-считывается информация о приложении. посылаю команду и пытаюсь считать результат - считывается такое же количество байт, что послал(колько в нечитабельном виде). результата нет. повторное считывание дает 0. такое ощущение, что посланная команда не отрабатывает. посмотреть что происходит в консоли нет возможности. помогите советом 0

Dragokas 18031 / 7734 / 892 Регистрация: 25.12.2011 Сообщений: 11,502 Записей в блоге: 16
	02.10.2016, 12:59
	Где код? 0

@fever brain oh my god 1456 / 796 / 161 Регистрация: 05.01.2016 Сообщений: 2,307 Записей в блоге: 8
	03.10.2016, 10:24
	Смотря какое приложение, и какой код возврата у этого приложения в любом случае обычно при нормальном завершении код возврата =0 Добавлено через 6 минут Да и вот еще что, если вы выкладываетево вложениях, то хотябы предупреждайте что там у вас документ в формате .dcom который я незнаю и знать не хочу чем он запускается, здесь же раздел vb6 не нак-ли.. 0

@_r_m_b_ 0 / 0 / 0 Регистрация: 29.09.2016 Сообщений: 10
	03.10.2016, 12:36
	файл ms word с поддержкой макросов. макросы написаны на VBA: такой же VB... очень жаль, что Вы не смогли помочь(даже не посмотрели какое приложение запускается). буду очень признателен, если кто-то откликнется 0

@_r_m_b_ 0 / 0 / 0 Регистрация: 29.09.2016 Сообщений: 10
	04.10.2016, 09:15
	Dragokas, спасибо за отклик. попробую попросить подсказок в другой ветке. вариант с задержками не красив и его можно попробовать просто в качестве примера, но не решения. приложение cmd, приведено, тоже в качестве примера. на практике должно работать другое. если этот вариант не решится, то лучше вообще бросить эту затею. 0