Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "模块1"




Public Function UrlEncode(ByRef szString As String) As String
       Dim szChar   As String
       Dim szTemp   As String
       Dim szCode   As String
       Dim szHex    As String
       Dim szBin    As String
       Dim iCount1  As Integer
       Dim iCount2  As Integer
       Dim iStrLen1 As Integer
       Dim iStrLen2 As Integer
       Dim lResult  As Long
       Dim lAscVal  As Long
       szString = Trim$(szString)
       iStrLen1 = Len(szString)
       For iCount1 = 1 To iStrLen1
           szChar = Mid$(szString, iCount1, 1)
           lAscVal = AscW(szChar)
           If lAscVal >= &H0 And lAscVal <= &HFF Then
              If (lAscVal >= &H30 And lAscVal <= &H39) Or _
                 (lAscVal >= &H41 And lAscVal <= &H5A) Or _
                 (lAscVal >= &H61 And lAscVal <= &H7A) Then
                 szCode = szCode & szChar
              Else
                 szCode = szCode & "%" & Hex(AscW(szChar))
              End If
           Else
              szHex = Hex(AscW(szChar))
              iStrLen2 = Len(szHex)
              For iCount2 = 1 To iStrLen2
                  szChar = Mid$(szHex, iCount2, 1)
                  Select Case szChar
                         Case Is = "0"
                              szBin = szBin & "0000"
                         Case Is = "1"
                              szBin = szBin & "0001"
                         Case Is = "2"
                              szBin = szBin & "0010"
                         Case Is = "3"
                              szBin = szBin & "0011"
                         Case Is = "4"
                              szBin = szBin & "0100"
                         Case Is = "5"
                        szBin = szBin & "0101"
                         Case Is = "6"
                              szBin = szBin & "0110"
                         Case Is = "7"
                              szBin = szBin & "0111"
                         Case Is = "8"
                              szBin = szBin & "1000"
                         Case Is = "9"
                              szBin = szBin & "1001"
                         Case Is = "A"
                              szBin = szBin & "1010"
                         Case Is = "B"
                              szBin = szBin & "1011"
                         Case Is = "C"
                              szBin = szBin & "1100"
                         Case Is = "D"
                              szBin = szBin & "1101"
                         Case Is = "E"
                              szBin = szBin & "1110"
                         Case Is = "F"
                              szBin = szBin & "1111"
                         Case Else
                  End Select
              Next iCount2
              szTemp = "1110" & Left$(szBin, 4) & "10" & Mid$(szBin, 5, 6) & "10" & Right$(szBin, 6)
              For iCount2 = 1 To 24
                  If Mid$(szTemp, iCount2, 1) = "1" Then
                     lResult = lResult + 1 * 2 ^ (24 - iCount2)
                  Else: lResult = lResult + 0 * 2 ^ (24 - iCount2)
                  End If
              Next iCount2
              szTemp = Hex(lResult)
                    szCode = szCode & "%" & Left$(szTemp, 2) & "%" & Mid$(szTemp, 3, 2) & "%" & Right$(szTemp, 2)
           End If
szBin = vbNullString
           lResult = 0
       Next iCount1
       UrlEncode = szCode
End Function




'--------------------------------------------用不着的函数，备用-------------------------------------------------------------





Public Function Escape(ByVal strText As String) As String
Dim JS
    'Set JS = CreateObjectx("MSScriptControl.ScriptControl")   '正常使用
    Set JS = CreateObjectx86("MSScriptControl.ScriptControl")
    JS.Language = "JavaScript"
    Escape = JS.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');")
End Function

Public Function Escape86(ByVal strText As String) As String
Dim JS
    'Set JS = CreateObjectx("MSScriptControl.ScriptControl")   '正常使用
    Set JS = CreateObjectx86("MSScriptControl.ScriptControl")
    JS.Language = "JavaScript"
    Escape = JS.Eval("encodeURI('" & Replace(strText, "'", "\'") & "');")
End Function



Function CreateObjectx86(Optional sProgID, Optional bClose = False)

    Static oWnd As Object
    Dim bRunning As Boolean

    #If Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject(sProgID)
    #End If

End Function



Function CreateWindow()

    ' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
    Dim sSignature, oShellWnd, oProc

    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
             Set CreateWindow = oShellWnd.GetProperty(sSignature)
             If Err.Number = 0 Then Exit Function
             Err.Clear
        Next
    Loop

End Function


Function URLDecode(ByVal What)
 'URL decode Function
'2001 Antonin Foller, PSTRUH Software, http://www.motobit.com
   Dim Pos, pPos

  'replace + To Space
   What = Replace(What, "+", " ")

  On Error Resume Next
  Dim Stream: Set Stream = CreateObject("ADODB.Stream")
  If Err = 0 Then 'URLDecode using ADODB.Stream, If possible
     On Error GoTo 0
    Stream.Type = 2 'String
     Stream.Open

    'replace all %XX To character
    Pos = InStr(1, What, "%")
    pPos = 1
    Do While Pos > 0
      Stream.WriteText Mid(What, pPos, Pos - pPos) + _
        Chr(CLng("&H" & Mid(What, Pos + 1, 2)))
      pPos = Pos + 3
      Pos = InStr(pPos, What, "%")
    Loop
    Stream.WriteText Mid(What, pPos)

    'Read the text stream
    Stream.Position = 0
    URLDecode = Stream.ReadText

    'Free resources
    Stream.Close
  Else 'URL decode using string concentation
    On Error GoTo 0
    'UfUf, this is a little slow method.
    'Do Not use it For data length over 100k
    Pos = InStr(1, What, "%")
    Do While Pos > 0
      What = Left(What, Pos - 1) + _
        Chr(CLng("&H" & Mid(What, Pos + 1, 2))) + _
        Mid(What, Pos + 3)
      Pos = InStr(Pos + 1, What, "%")
    Loop
    URLDecode = What
  End If
End Function





'产生随机数

Public Function sjs(n As Long) As String
Randomize
Dim ar, i, j, k
ReDim ar(1 To n)
For i = 1 To n
    ar(i) = Int(Rnd * 10)
    k = Int(Rnd * n + 1)
Next i
For j = 1 To k
    ar(Int(Rnd * n + 1)) = Chr(Int(Rnd * 26 + 65))
Next
sjs = Join(ar, "")
End Function

Sub 删除前两行()
    Rows("1:2").Select
    Selection.Delete Shift:=xlShiftUp
End Sub

Sub 首行居下()
    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub
Sub 行11行后缩小单元格()
ConSName = ActiveSheet.Name & PZNAME
    Rows(startrow + 1 & ":" & startrow + 1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlDown)).Select
        Range(Selection, Selection.End(xlDown)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = True
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Rows(startrow & ":" & startrow).Select
End Sub
Sub updatesheet2()

  Dim aa As String
  Dim fromsheet, tosheet As String
  fromsheet = "Sheet1"
  tosheet = "Sheet2"
  
  Sheets(fromsheet).Select

    
    Sheets(tosheet).Select
    UploadExcel
      Sheets(fromsheet).Select
End Sub

Sub updateothersheets()
  Dim aa As String
  Dim fromsheet, tosheet As String
  fromsheet = "Sheet1"
  tosheet = "Sheet2"
  
  Sheets(fromsheet).Select
    UpdateBySheet
    
    aa = updatesheetfrun("Sheet1", "Sheet2")
    
    Sheets(tosheet).Select
    UploadExcel
    
End Sub

Function updatesheetfrun(ByVal fromsheet As String, ByVal tosheet As String)
ConSName = ActiveSheet.Name & PZNAME
    Sheets(tosheet).Select
    Rows(startrow & ":" & startrow).Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.ClearContents
    Range("D13").Select
    Sheets(fromsheet).Select
    Range("A10").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Copy
    Sheets(tosheet).Select
    Range(startcell).Select
    ActiveSheet.Paste
End Function

Sub 回车符转换成回车()
    Cells.Select
    Selection.Replace "\n", Chr(10)
    Range(startcell).Select
End Sub

Function Postfile(ByVal FileFullPath As String)
ConSName = ActiveSheet.Name & PZNAME
Set fso = CreateObject("scripting.filesystemobject")
Dim trueupurl
If ((Sheets(ConSName).Range(siteuer).Value <> "") And (Sheets(ConSName).Range(sitepassword).Value) <> "") Then
    trueupurl = uponefileurlcom
Else
    trueupurl = uponefileurl
End If
ext = fso.GetExtensionName(FileFullPath)

updateweb = Sheets(ConSName).Range(website).Value & trueupurl
    
Dim UploadData, tempFileName, loadStatus

tempFileName = "upload." & ext
Set UploadData = New XMLUpload
conall = "fdf"
UploadData.Charset = "utf-8"
UploadData.AddForm "conall", conall '文本域的名称和内容
UploadData.AddFile "file", tempFileName, "application/octet-stream", FileFullPath

loadStatus = UploadData.Upload(updateweb)

Set fso = Nothing
Set UploadData = Nothing

Postfile = loadStatus
   Dim f As String

End Function




Function txt_read(ByVal filepath As String)
       Dim txt As String
        Open filepath For Input As #1 '
        '对文件做任何 I/O 操作之前都必须先打开文件。Open 语句分配一个缓冲区供文件进行 I/O 之用，
        '并决定缓冲区所使用的访问方式。
        '打开文件作为数据输入用，文件号为#1
        Line Input #1, txt
        Close #1
        txt_read = txt
End Function



Sub ToJson() '创建UTF8文本文件

 myrange = ActiveSheet.UsedRange '通过有效数据区来选择数据
 'myrange = ActiveWorkbook.Names("schoolinfo").RefersToRange '通过定义的名称来选择数据
 'myrange = sheets(ConSName).Range(Worksheets("sheet1").sheets(ConSName).Range("a1").End(xlDown), Worksheets("sheet1").sheets(ConSName).Range("a1").End(xlToRight)) '通过标题行的最大行最大列来选择数据
  
Total = UBound(myrange, 1) '获取行数
Fields = UBound(myrange, 2) '获取列数
  
   Dim objStream As Object
   Set objStream = CreateObject("ADODB.Stream")
    
   With objStream
      .Type = 2
      .Charset = "UTF-8"
      .Open
      .WriteText "{""total"":" & Total & ",""contents"":["
    
      For i = 2 To Total
        .WriteText "{"
        For j = 1 To Fields
          .WriteText """" & myrange(1, j) & """:""" & Replace(myrange(i, j), """", "\""") & """"
           If j <> Fields Then
            .WriteText ","
           End If
        Next
        If i = Total Then
            .WriteText "}"
        Else
            .WriteText "},"
        End If
      Next
  
      .WriteText "]}"
      .SaveToFile ActiveWorkbook.FullName & ".json", 2
   End With
   Set objStream = Nothing
End Sub





'写入文件，windows打开有问题，但可以运行
Function Writefile(ByVal filename As String, ByVal content As String, Optional filetype As String = "gbk")
    Dim WriteStream As Object
    If filename = Empty Then
        filename = Range(MYFILENAMECELL).Value
    End If
    Set WriteStream = CreateObject("ADODB.Stream")
    With WriteStream
        .Type = 2               'adTypeText
        .Charset = filetype
        .Open
        .WriteText content
        .SaveToFile filename, 2  'adSaveCreateOverWrite
        .Flush
        .Close
    End With
    Set WriteStream = Nothing
End Function

'读取文件
Function readfile(ByVal filename As String, Optional filetype As String = "gbk")
 Dim ReadStream As Object
    Set ReadStream = CreateObject("ADODB.Stream")
    Dim FileContent As String
    With ReadStream
        .Type = 2               'adTypeText
        '.Charset = "UNICODE"
        '.Charset = "GB2312"     ' ANSI
        '.Charset = "UTF-8"
        .Charset = filetype
        .Open
        .LoadFromFile filename
        FileContent = .ReadText
        .Close
    End With
readfile = FileContent
End Function





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

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

Attribute VB_Name = "Sheet1"
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 = "XMLUpload"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'http://demon.tw/
'XML Upload Class

    Private xmlHttp
    Private objTemp
    Private adTypeBinary, adTypeText
    Private strCharset, strBoundary

    Private Sub Class_Initialize()
        adTypeBinary = 1
        adTypeText = 2
        Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
        Set objTemp = CreateObject("ADODB.Stream")
        objTemp.Type = adTypeBinary
        objTemp.Open
        strCharset = "utf-8"
        strBoundary = GetBoundary()
    End Sub

    Private Sub Class_Terminate()
        objTemp.Close
        Set objTemp = Nothing
        Set xmlHttp = Nothing
    End Sub

    '指定字符集的字符串转字节数组
    Public Function StringToBytes(ByVal strData, ByVal strCharset)
        Dim objFile
        Set objFile = CreateObject("ADODB.Stream")
        objFile.Type = adTypeText
        objFile.Charset = strCharset
        objFile.Open
        objFile.WriteText strData
        objFile.Position = 0
        objFile.Type = adTypeBinary
        If UCase(strCharset) = "UNICODE" Then
            objFile.Position = 2 'delete UNICODE BOM
        ElseIf UCase(strCharset) = "UTF-8" Then
            objFile.Position = 3 'delete UTF-8 BOM
        End If
        StringToBytes = objFile.Read(-1)
        objFile.Close
        Set objFile = Nothing
    End Function

    '获取文件内容的字节数组
    Private Function GetFileBinary(ByVal strPath)
        Dim objFile
        Set objFile = CreateObject("ADODB.Stream")
        objFile.Type = adTypeBinary
        objFile.Open
        objFile.LoadFromFile strPath
        GetFileBinary = objFile.Read(-1)
        objFile.Close
        Set objFile = Nothing
    End Function

    '获取自定义的表单数据分界线
    Private Function GetBoundary()
        Dim ret(13)
        Dim table
        Dim i
        table = "abcdefghijklmnopqrstuvwxzy0123456789"
        Randomize
        For i = 0 To UBound(ret)
            ret(i) = Mid(table, Int(Rnd() * Len(table) + 1), 1)
        Next
        GetBoundary = "-----------------------------" & Join(ret, Empty)
    End Function

    '设置上传使用的字符集
    Public Property Let Charset(ByVal strValue)
        strCharset = strValue
    End Property

    '添加文本域的名称和值
    Public Sub AddForm(ByVal strName, ByVal strValue)
        Dim tmp
        tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""\r\n\r\n$3"
        tmp = Replace(tmp, "\r\n", vbCrLf)
        tmp = Replace(tmp, "$1", strBoundary)
        tmp = Replace(tmp, "$2", strName)
        tmp = Replace(tmp, "$3", strValue)
        objTemp.write StringToBytes(tmp, strCharset)
    End Sub

    '设置文件域的名称/文件名称/文件MIME类型/文件路径或文件字节数组
    Public Sub AddFile(ByVal strName, ByVal strFileName, ByVal strFileType, ByVal strFilePath)
        Dim tmp
        tmp = "\r\n--$1\r\nContent-Disposition: form-data; name=""$2""; filename=""$3""\r\nContent-Type: $4\r\n\r\n"
        tmp = Replace(tmp, "\r\n", vbCrLf)
        tmp = Replace(tmp, "$1", strBoundary)
        tmp = Replace(tmp, "$2", strName)
        tmp = Replace(tmp, "$3", strFileName)
        tmp = Replace(tmp, "$4", strFileType)
        objTemp.write StringToBytes(tmp, strCharset)
        objTemp.write GetFileBinary(strFilePath)
    End Sub

    '设置multipart/form-data结束标记
    Private Sub AddEnd()
        Dim tmp
        tmp = "\r\n--$1--\r\n"
        tmp = Replace(tmp, "\r\n", vbCrLf)
        tmp = Replace(tmp, "$1", strBoundary)
        objTemp.write StringToBytes(tmp, strCharset)
        objTemp.Position = 2
    End Sub

    '打开URL，然后上传文件，并返回服务器应答
    Public Function Upload(ByVal strURL)
            Call AddEnd
            xmlHttp.Open "POST", strURL, False
            xmlHttp.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & strBoundary
            'xmlHttp.setRequestHeader "Content-Length", objTemp.size
            xmlHttp.Send objTemp
           Upload = xmlHttp.responsetext
    End Function

'Excel中VBA转换文件编码到UTF-8
Public Function ConvFile(InputFile As String, OutputFile As String)
 
    Dim ReadStream As Object
    Set ReadStream = CreateObject("ADODB.Stream")
    
    Dim FileContent As String
    
    With ReadStream
        .Type = 2               'adTypeText
        '.Charset = "UNICODE"
        .Charset = "GB2312"     ' ANSI
        '.Charset = "UTF-8"
        .Open
        .LoadFromFile InputFile
        FileContent = .ReadText
        .Close
        
    End With
    
    Set ReadStream = Nothing
    
    
    
    Dim WriteStream As Object
    Set WriteStream = CreateObject("ADODB.Stream")
       
    
    With WriteStream
        .Type = 2               'adTypeText
        .Charset = "UTF-8"
        .Open
        .WriteText FileContent
        .SaveToFile OutputFile, 2  'adSaveCreateOverWrite
        
        .Flush
        .Close
        
    End With
    
    Set WriteStream = Nothing
 
    
End Function



Attribute VB_Name = "Sheet3"
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