Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 dd74499ca3bf9dac…

MALICIOUS

Office (OOXML)

261.0 KB Created: 2019-10-01 12:18:50 UTC Authoring application: Microsoft Excel 14.0300 First seen: 2026-06-05
MD5: 39e4c2cba7dd7d935c09e637e2704568 SHA-1: 2a4597b9bc43206ea3a7145985b62fc0515f3be2 SHA-256: dd74499ca3bf9dac9f406c9eb06a719c9884831edde3a845d1f9f6cdfcdbd411
338 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1566.001 Spearphishing Attachment

The sample is an Excel document containing VBA macros, indicated by multiple OLE_VBA heuristics. The Workbook_Open macro is present and uses WScript.Shell and CreateObject, suggesting an attempt to execute arbitrary code. The macro likely attempts to download and execute a second-stage payload from the URL http://www.eurekabpo.ru, disguised as a regulatory document.

Heuristics 10

  • VBA project inside OOXML medium 7 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
            Shell (test)
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Set WshShell = CreateObject("WScript.Shell")
  • LOLBin reference in VBA critical OLE_VBA_LOLBIN
    LOLBin reference in VBA
    Matched line in script
        Set WshExec = WshShell.Exec("certutil -encode """ & pdf.path & """ " & """" & encodeFilePath & """")
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set WshShell = CreateObject("WScript.Shell")
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
          Set objVMI = GetObject(test & dot & root)
  • 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()
  • Hidden worksheet (veryHidden, hidden) low OOXML_HIDDEN_SHEET
    Excel workbook contains 3 hidden sheet(s) — hidden sheets are commonly used to conceal macro code, staging data, or intermediate payload construction
  • 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://www.eurekabpo.ru In document text (OOXML body / shared strings)
    • http://www.w3.org/2001/XMLSchema-instanceIn 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) 235755 bytes
SHA-256: 4d425515a2e34565d51da00b6b3825a2e27ea54449a7cbc6a851a40708b7805c
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "Worksheet____1"
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
Public submitFromForm As Boolean
Dim currentSelection As Range
Public editRejected As Boolean
Public rowsCount As Long
Dim sequenceNumCell As Range, docNameInitialCell As Range, docCodeInitnialCell As Range, DocTypeInitialCell As Range, initialItemTypeCell As Range, initialCell As Range, DocActionInitialCell As Range, DossierNamecell As Range

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If docCodeInitnialCell Is Nothing Then
        Call initInitialCells
    End If
    Dim hasValue As Boolean, isNotHeader As Boolean
    hasValue = ActiveSheet.Cells(Target.row, docNameInitialCell.Column).Value <> ""
    isNotHeader = Target.row > 8
    Dim DossierBlocked As Boolean: DossierBlocked = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            DossierBlocked = Property.Value
            Exit For
        End If
    Next
    
    If (isNotHeader) And (Not DossierBlocked) Then
        If hasValue And (Target.Column = docCodeInitnialCell.Column) Then
            Dim form As UserForm2
            Set form = New UserForm2
            form.Property_CalledFrom = Target
            form.CustomShow
        ElseIf Target.Column = DocActionInitialCell.Column And Module1.sequenceNumToInt(sequenceNumCell.Value) > 0 Then
            Dim actionForm As ChooseDocActionForm
            Set actionForm = New ChooseDocActionForm
            actionForm.Property_CalledFrom = Target
            actionForm.Show
        End If
    End If
    
End Sub

' Делаем ячейку с номером последовательности только для чтения
Private Sub Worksheet_Change(ByVal Target As Range)
    If sequenceNumCell Is Nothing Then
        Call initInitialCells
    End If
    Dim currentRowsCount As Long: currentRowsCount = ActiveSheet.Cells(ActiveSheet.rows.count, 1).End(xlUp).row
    Dim forceChange As Boolean: forceChange = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "ForceChange" Then
            forceChange = Property.Value
            Exit For
        End If
    Next
    
     Dim DossierBlocked As Boolean: DossierBlocked = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            DossierBlocked = Property.Value
            Exit For
        End If
    Next
    If DossierBlocked Then
        On Error Resume Next
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With

        MsgBox "Создана следующая версия досье. Данная версия недоступна для редактирования"
    ElseIf Not forceChange Then
        ' Сравниеваем не по адресу потому что при change таргет всегда одна ячейка, а sequenceNumCell - это объединение ячеек - адреса разные
        If (Target.Column = sequenceNumCell.Column And Target.row = sequenceNumCell.row) And Not editRejected Then
            Dim errMsg As String
            editRejected = True
            errMsg = "Версия досье устанавливается автоматически" & vbNewLine & "Чтобы перевести Досье на следующую версию, нажмите кнопку " & Chr(34) & "Создать след. версию Досье" & Chr(34)
            MsgBox errMsg, vbInformation + vbOKOnly, "ФАРДО - Редактирование таблицы"
            Application.Undo
        End If
        ' Обрабатываем удаление строки - актуализируем данные
        If Target.Columns.count = Worksheets("Досье").Columns.count And Me.rowsCount > currentRowsCount Then
            Call Module1.removeNotActialDataFromHiddenDict
        End If
        Dim currentRow As Range
        Set currentRow = ActiveSheet.rows(Target.row)
        If docCodeInitnialCell.Column = Target.Column Then
            Call Module1.SaveLocalFileInfo(currentRow)
        End If
        Dim docActionCell As Range
        Set docActionCell = DocActionInitialCell.Offset(Target.row - DocActionInitialCell.row)
        ' Если выделяем строку целиком - то вылетает ошибка
        On Error Resume Next
        If Not Intersect(currentSelection, docActionCell) Is Nothing Then
            If docActionCell.Value = "" Then
                Call Module1.removeNotActialDataFromHiddenDict
            End If
        End If
        editRejected = False
    End If
    Me.rowsCount = currentRowsCount
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set currentSelection = Target
End Sub

Private Function initInitialCells()
    Set docNameInitialCell = Application.Names("InitialDocNameCell").RefersToRange
    Set DocTypeInitialCell = Application.Names("DocTypeInitialCell").RefersToRange
    Set docCodeInitnialCell = Application.Names("initialDocCodeCell").RefersToRange
    Set sequenceNumCell = Application.Names("SequenceNumCell").RefersToRange
    Set initialItemTypeCell = Application.Names("InitialItemTypeCell").RefersToRange
    Set initialCell = Application.Names("InitialCell").RefersToRange
    Set DocActionInitialCell = Application.Names("DocActionInitialCell").RefersToRange
    
End Function

Private Function mapSelectionCellToHiddenRange(selectedCell As Range) As Range
    If Not Intersect(currentSelection, selectedCell) Is Nothing Then
        Dim col As Integer, row As Integer
        col = Range(currentSelection(1), selectedCell).Columns.count
        row = Range(currentSelection(1), selectedCell).rows.count
        Set mapSelectionCellToHiddenRange = currentSelectedList.UsedRange(row, col)
    End If
End Function




Attribute VB_Name = "Worksheet____2"
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 = "Worksheet____3"
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 = "Workbook________"
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 Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim hasProp As Boolean
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            Property.Value = ActiveCell.Address
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveCell", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveCell.Address
    End If
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            Property.Value = ActiveSheet.name
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveSheet", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveSheet.name
    End If
    WelcomeList.Visible = xlSheetVisible
    WelcomeList.Activate
    
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim hasProp As Boolean
    If ActiveSheet.name <> "Лист1" Then
        Call saveCurrentCellPos
    End If
End Sub

Private Sub Workbook_Open()
Dim DossierBlocked As Boolean: DossierBlocked = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            DossierBlocked = Property.Value
            If DossierBlocked Then
                Property.Value = False
                disableDossierActions
            End If
            Exit For
        End If
    Next
    Dim currentCodeVersion As String
    Dim InitalCell As Range
    initialCell = Names("InitialCell").RefersToRange
    currentCodeVersion = "v1.0.26"
    Dim versionCell As Range: Set versionCell = Names("VersionCell").RefersToRange
    versionCell.NumberFormat = "@"
    versionCell.Value = currentCodeVersion
    Dim settingsVersionCell As Range: Set settingsVersionCell = Names("SettingsVersionCell").RefersToRange
    settingsVersionCell.NumberFormat = "@"
    settingsVersionCell.Value = currentCodeVersion
    Dim DossierNamecell As Range: Set DossierNamecell = Names("DossierNameCell").RefersToRange
    DossierNamecell.Value = Module1.GetFolderName()
    
    Dim lasActiveCellAddr As String, lasActiveSheetName As String
    
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            lasActiveSheetName = Property.Value
            Exit For
        End If
    Next
    If lasActiveSheetName <> "" Then
        Sheets(lasActiveSheetName).Activate
        If lasActiveCellAddr <> "" Then
            Range(lasActiveCellAddr).Activate
        End If
    Else
        
        Call initialCell.Activate
    End If
    WelcomeList.Visible = xlSheetVeryHidden
    
    If checkPropertyExist() = False And isUpdated = False And Module1.PROTECTED = True Then 'Раскомментировать при формировании защищенной копии
        Dim activationCell As Range
        Dim settingsActivationCell As Range
        Set activationCell = Names("ActivationCell").RefersToRange
        activationCell.Font.Color = RGB(245, 10, 10)
        activationCell.Value = "Не активирован"
        Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
        settingsActivationCell.Font.Color = RGB(245, 10, 10)
        settingsActivationCell.Value = "Не активирован"
        UserForm5.Show False
    End If

If DossierBlocked Then
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            Property.Value = True
            Exit For
        End If
    Next
Else
    enableDossierActions
End If
End Sub

Private Function isUpdated() As Boolean
    Dim basePath As String: basePath = ActiveWorkbook.path
    isUpdated = False
    If Len(dir(ActiveWorkbook.path & "\old.xlsm")) > 0 Then
        Module3.copyText
    End If
    If dir(basePath & "\key") <> "" Then
       ' Навешиваем флаг для разрешения редактирования ячеек досье
       
       Dim f_in As Integer
       f_in = FreeFile()
       Open basePath & "\key" For Input As #f_in
       Dim test1 As Integer: test1 = 0
       Do While Not EOF(f_in)
           Line Input #f_in, sLine
           Dim splitString() As String
           result = result & sLine
       Loop
       Close #f_in
       Kill basePath & "\key"
       Dim test As String
        Dim temp() As String
        Dim splitStr() As String
        
        splitStr = Split(result, "$$$$")
        
        If UBound(splitStr) - LBound(splitStr) = 1 Then
            test = splitStr(0)
            temp = Split(test, ",")
            Call Module1.filTable(temp)
            Dim propertyExist As Boolean: propertyExist = False
            Dim code As String: code = splitStr(1)
            Dim activationCell As Range: Set activationCell = Names("ActivationCell").RefersToRange
            activationCell.Font.Color = RGB(84, 230, 55)
            activationCell.Value = "Активирован"
                
            Dim settingsActivationCell As Range: Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
            settingsActivationCell.Font.Color = RGB(84, 230, 55)
            settingsActivationCell.Value = "Активирован"
            
            For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
                If Property.name = "asadsjakdjhask" Then
                    Property.Value = code
                    propertyExist = True
                    Exit For
                End If
            Next
            If propertyExist = False Then
                ActiveWorkbook.CustomDocumentProperties.Add _
                    name:="asadsjakdjhask", _
                    LinkToContent:=False, _
                    Type:=msoPropertyTypeString, _
                    Value:=code
            End If
            ActiveWorkbook.Save
            isUpdated = True
        End If
     End If
End Function

Function enableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 0
End Function

Function disableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 8421504
End Function

Function disableDossierActions()
    Dim fillFoldersBtn As Shape, fillTableBtn As Shape, dossierCheckAndExportBtn As Shape, updateBtn As Shape, increaseSeqBtn As Shape, newDossierBtn As Shape
    Dim dossierSheet As Worksheet
    Set dossierSheet = Worksheet____1
    Dim settingsSheet As Worksheet
    Set settingsSheet = Worksheet____4
    Set fillFoldersBtn = dossierSheet.Shapes("Кнопка 6")
    Set fillTableBtn = dossierSheet.Shapes("Кнопка 7")
    Set dossierCheckAndExportBtn = dossierSheet.Shapes("Кнопка 3")
    Set increaseSeqBtn = dossierSheet.Shapes("Кнопка 8")
    Set updateBtn = settingsSheet.Shapes("Кнопка 1")
    Set newDossierBtn = settingsSheet.Shapes("Кнопка 2")
    
    Call disableShapeButton(fillFoldersBtn)
    Call disableShapeButton(fillTableBtn)
    Call disableShapeButton(dossierCheckAndExportBtn)
    Call disableShapeButton(increaseSeqBtn)
    Call disableShapeButton(updateBtn)
    Call disableShapeButton(newDossierBtn)
    
    BtnsDisabled = True
End Function

Function enableDossierActions()
    Dim dossierSheet As Worksheet
    Set dossierSheet = Worksheet____1
     Dim settingsSheet As Worksheet
    Set settingsSheet = Worksheet____4
    Dim fillFoldersBtn As Shape, fillTableBtn As Shape, dossierCheckAndExportBtn As Shape, updateBtn As Shape, increaseSeqBtn As Shape, newDossierBtn As Shape
    Set fillFoldersBtn = dossierSheet.Shapes("Кнопка 6")
    Set fillTableBtn = dossierSheet.Shapes("Кнопка 7")
    Set dossierCheckAndExportBtn = dossierSheet.Shapes("Кнопка 3")
    Set increaseSeqBtn = dossierSheet.Shapes("Кнопка 8")
    Set updateBtn = settingsSheet.Shapes("Кнопка 1")
    Set newDossierBtn = settingsSheet.Shapes("Кнопка 2")
    
    Call enableShapeButton(fillFoldersBtn)
    Call enableShapeButton(fillTableBtn)
    Call enableShapeButton(dossierCheckAndExportBtn)
    Call enableShapeButton(increaseSeqBtn)
    Call enableShapeButton(updateBtn)
    Call enableShapeButton(newDossierBtn)
    
    BtnsDisabled = False
End Function
Private Function saveCurrentCellPos()
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            Property.Value = ActiveCell.Address
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveCell", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveCell.Address
    End If
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            Property.Value = ActiveSheet.name
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveSheet", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveSheet.name
    End If
End Function


Attribute VB_Name = "JsonConverter"

Attribute VB_Name = "barForm"
Attribute VB_Base = "0{51DA5E55-0E43-4D68-AE90-3D481182D5BB}{B3A7F26A-3E33-4EF1-B199-2E57441D54FE}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = vbFormControlMenu Then
        ans = MsgBox("Вы уверены, что хотите остановить процесс?", _
            vbOKCancel, "Остановить процесс?")
        If ans = 1 Then
            Unload Me
            Call Module1.enableDossierActions
            End
        Else
            Cancel = 1
        End If
    End If
End Sub



Attribute VB_Name = "UserForm8"
Attribute VB_Base = "0{0482F363-746F-4004-A9C5-14C8FB952C68}{D8F58C7D-D5A3-4001-8FD6-B2D7122E618E}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub CommandButton2_Click()
    Dim procedureKind As String
    procedureKind = "01"
    If Me.OptionButton2.Value = True Then
        procedureKind = "02"
    End If
    Unload Me
    Call Macro3(procedureKind)
End Sub

Attribute VB_Name = "WelcomeList"
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 = "currentSelectedList"
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 = "Workbook________1"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim hasProp As Boolean
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            Property.Value = ActiveCell.Address
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveCell", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveCell.Address
    End If
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            Property.Value = ActiveSheet.name
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveSheet", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveSheet.name
    End If
    WelcomeList.Visible = xlSheetVisible
    WelcomeList.Activate
    
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim hasProp As Boolean
    If ActiveSheet.name <> "Лист1" Then
        Call saveCurrentCellPos
    End If
End Sub

Private Sub Workbook_Open()
Dim DossierBlocked As Boolean: DossierBlocked = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            DossierBlocked = Property.Value
            If DossierBlocked Then
                Property.Value = False
                disableDossierActions
            End If
            Exit For
        End If
    Next
    Dim currentCodeVersion As String
    Dim InitalCell As Range
    initialCell = Names("InitialCell").RefersToRange
    currentCodeVersion = "v1.0.14"
    Dim versionCell As Range: Set versionCell = Names("VersionCell").RefersToRange
    versionCell.NumberFormat = "@"
    versionCell.Value = currentCodeVersion
    Dim settingsVersionCell As Range: Set settingsVersionCell = Names("SettingsVersionCell").RefersToRange
    settingsVersionCell.NumberFormat = "@"
    settingsVersionCell.Value = currentCodeVersion
    Dim DossierNamecell As Range: Set DossierNamecell = Names("DossierNameCell").RefersToRange
    DossierNamecell.Value = Module1.GetFolderName()
    
    Dim lasActiveCellAddr As String, lasActiveSheetName As String
    
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            lasActiveSheetName = Property.Value
            Exit For
        End If
    Next
    If lasActiveSheetName <> "" Then
        Sheets(lasActiveSheetName).Activate
        If lasActiveCellAddr <> "" Then
            Range(lasActiveCellAddr).Activate
        End If
    Else
        
        Call initialCell.Activate
    End If
    WelcomeList.Visible = xlSheetVeryHidden
    
'    If checkPropertyExist() = False And isUpdated = False Then 'Раскомментировать при формировании защищенной копии
'        Dim activationCell As Range
'        Dim settingsActivationCell As Range
'        Set activationCell = Names("ActivationCell").RefersToRange
'        activationCell.Font.Color = RGB(245, 10, 10)
'        activationCell.Value = "Не активирован"
'        Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
'        settingsActivationCell.Font.Color = RGB(245, 10, 10)
'        settingsActivationCell.Value = "Не активирован"
'        UserForm5.Show False
'    End If

If DossierBlocked Then
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            Property.Value = True
            Exit For
        End If
    Next
Else
    enableDossierActions
End If
End Sub

Private Function isUpdated() As Boolean
    Dim basePath As String: basePath = ActiveWorkbook.path
    isUpdated = False
    If dir(basePath & "\key") <> "" Then
       ' Навешиваем флаг для разрешения редактирования ячеек досье
       
       Dim f_in As Integer
       f_in = FreeFile()
       Open basePath & "\key" For Input As #f_in
       Dim test1 As Integer: test1 = 0
       Do While Not EOF(f_in)
           Line Input #f_in, sLine
           Dim splitString() As String
           result = result & sLine
       Loop
       Close #f_in
       Kill basePath & "\key"
       Dim test As String
        Dim temp() As String
        Dim splitStr() As String
        
        splitStr = Split(result, "$$$$")
        
        If UBound(splitStr) - LBound(splitStr) = 1 Then
            test = splitStr(0)
            temp = Split(test, ",")
            Call Module1.filTable(temp)
            Dim propertyExist As Boolean: propertyExist = False
            Dim code As String: code = splitStr(1)
            Dim activationCell As Range: Set activationCell = Names("ActivationCell").RefersToRange
            activationCell.Font.Color = RGB(84, 230, 55)
            activationCell.Value = "Активирован"
                
            Dim settingsActivationCell As Range: Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
            settingsActivationCell.Font.Color = RGB(84, 230, 55)
            settingsActivationCell.Value = "Активирован"
            
            For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
                If Property.name = "asadsjakdjhask" Then
                    Property.Value = code
                    propertyExist = True
                    Exit For
                End If
            Next
            If propertyExist = False Then
                ActiveWorkbook.CustomDocumentProperties.Add _
                    name:="asadsjakdjhask", _
                    LinkToContent:=False, _
                    Type:=msoPropertyTypeString, _
                    Value:=code
            End If
            ActiveWorkbook.Save
            Module3.copyText
            isUpdated = True
        End If
     End If
End Function

Function enableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 0
End Function

Function disableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 8421504
End Function

Function disableDossierActions()
    Dim fillFoldersBtn As Shape, fillTableBtn As Shape, dossierCheckBtn As Shape, xmlExportBtn As Shape, updateBtn As Shape, increaseSeqBtn As Shape, newDossierBtn As Shape
    Dim dossierSheet As Worksheet
    Set dossierSheet = Worksheet____1
    Dim settingsSheet As Worksheet
    Set settingsSheet = Worksheet____4
    Set fillFoldersBtn = dossierSheet.Shapes("Кнопка 6")
    Set fillTableBtn = dossierSheet.Shapes("Кнопка 7")
    Set dossierCheckBtn = dossierSheet.Shapes("Кнопка 3")
    Set xmlExportBtn = dossierSheet.Shapes("Кнопка 4")
    Set increaseSeqBtn = dossierSheet.Shapes("Кнопка 8")
    Set updateBtn = settingsSheet.Shapes("Кнопка 1")
    Set newDossierBtn = settingsSheet.Shapes("Кнопка 2")
    
    Call disableShapeButton(fillFoldersBtn)
    Call disableShapeButton(fillTableBtn)
    Call disableShapeButton(dossierCheckBtn)
    Call disableShapeButton(xmlExportBtn)
    Call disableShapeButton(increaseSeqBtn)
    Call disableShapeButton(updateBtn)
    Call disableShapeButton(newDossierBtn)
    
    BtnsDisabled = True
End Function

Function enableDossierActions()
    Dim dossierSheet As Worksheet
    Set dossierSheet = Worksheet____1
     Dim settingsSheet As Worksheet
    Set settingsSheet = Worksheet____4
    Dim fillFoldersBtn As Shape, fillTableBtn As Shape, dossierCheckBtn As Shape, xmlExportBtn As Shape, updateBtn As Shape, increaseSeqBtn As Shape, newDossierBtn As Shape
    Set fillFoldersBtn = dossierSheet.Shapes("Кнопка 6")
    Set fillTableBtn = dossierSheet.Shapes("Кнопка 7")
    Set dossierCheckBtn = dossierSheet.Shapes("Кнопка 3")
    Set xmlExportBtn = dossierSheet.Shapes("Кнопка 4")
    Set increaseSeqBtn = dossierSheet.Shapes("Кнопка 8")
    Set updateBtn = settingsSheet.Shapes("Кнопка 1")
    Set newDossierBtn = settingsSheet.Shapes("Кнопка 2")
    
    Call enableShapeButton(fillFoldersBtn)
    Call enableShapeButton(fillTableBtn)
    Call enableShapeButton(dossierCheckBtn)
    Call enableShapeButton(xmlExportBtn)
    Call enableShapeButton(increaseSeqBtn)
    Call enableShapeButton(updateBtn)
    Call enableShapeButton(newDossierBtn)
    
    BtnsDisabled = False
End Function
Private Function saveCurrentCellPos()
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            Property.Value = ActiveCell.Address
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveCell", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveCell.Address
    End If
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            Property.Value = ActiveSheet.name
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveSheet", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveSheet.name
    End If
End Function


Attribute VB_Name = "Workbook________2"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim hasProp As Boolean
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            Property.Value = ActiveCell.Address
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveCell", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveCell.Address
    End If
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            Property.Value = ActiveSheet.name
            hasProp = True
            Exit For
        End If
    Next
    If Not hasProp Then
        ActiveWorkbook.CustomDocumentProperties.Add _
            name:="LastActiveSheet", _
            LinkToContent:=False, _
            Type:=msoPropertyTypeString, _
            Value:=ActiveSheet.name
    End If
    WelcomeList.Visible = xlSheetVisible
    WelcomeList.Activate
    
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim hasProp As Boolean
    If ActiveSheet.name <> "Лист1" Then
        Call saveCurrentCellPos
    End If
End Sub

Private Sub Workbook_Open()
Dim DossierBlocked As Boolean: DossierBlocked = False
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            DossierBlocked = Property.Value
            If DossierBlocked Then
                Property.Value = False
                disableDossierActions
            End If
            Exit For
        End If
    Next
    Dim currentCodeVersion As String
    Dim InitalCell As Range
    initialCell = Names("InitialCell").RefersToRange
    currentCodeVersion = "v1.0.14"
    Dim versionCell As Range: Set versionCell = Names("VersionCell").RefersToRange
    versionCell.NumberFormat = "@"
    versionCell.Value = currentCodeVersion
    Dim settingsVersionCell As Range: Set settingsVersionCell = Names("SettingsVersionCell").RefersToRange
    settingsVersionCell.NumberFormat = "@"
    settingsVersionCell.Value = currentCodeVersion
    Dim DossierNamecell As Range: Set DossierNamecell = Names("DossierNameCell").RefersToRange
    DossierNamecell.Value = Module1.GetFolderName()
    
    Dim lasActiveCellAddr As String, lasActiveSheetName As String
    
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveCell" Then
            lasActiveCellAddr = Property.Value
            Exit For
        End If
    Next
    For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "LastActiveSheet" Then
            lasActiveSheetName = Property.Value
            Exit For
        End If
    Next
    If lasActiveSheetName <> "" Then
        Sheets(lasActiveSheetName).Activate
        If lasActiveCellAddr <> "" Then
            Range(lasActiveCellAddr).Activate
        End If
    Else
        
        Call initialCell.Activate
    End If
    WelcomeList.Visible = xlSheetVeryHidden
    
'    If checkPropertyExist() = False And isUpdated = False Then 'Раскомментировать при формировании защищенной копии
'        Dim activationCell As Range
'        Dim settingsActivationCell As Range
'        Set activationCell = Names("ActivationCell").RefersToRange
'        activationCell.Font.Color = RGB(245, 10, 10)
'        activationCell.Value = "Не активирован"
'        Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
'        settingsActivationCell.Font.Color = RGB(245, 10, 10)
'        settingsActivationCell.Value = "Не активирован"
'        UserForm5.Show False
'    End If

If DossierBlocked Then
     For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
        If Property.name = "DossierBlocked" Then
            Property.Value = True
            Exit For
        End If
    Next
Else
    enableDossierActions
End If
End Sub

Private Function isUpdated() As Boolean
    Dim basePath As String: basePath = ActiveWorkbook.path
    isUpdated = False
    If dir(basePath & "\key") <> "" Then
       ' Навешиваем флаг для разрешения редактирования ячеек досье
       
       Dim f_in As Integer
       f_in = FreeFile()
       Open basePath & "\key" For Input As #f_in
       Dim test1 As Integer: test1 = 0
       Do While Not EOF(f_in)
           Line Input #f_in, sLine
           Dim splitString() As String
           result = result & sLine
       Loop
       Close #f_in
       Kill basePath & "\key"
       Dim test As String
        Dim temp() As String
        Dim splitStr() As String
        
        splitStr = Split(result, "$$$$")
        
        If UBound(splitStr) - LBound(splitStr) = 1 Then
            test = splitStr(0)
            temp = Split(test, ",")
            Call Module1.filTable(temp)
            Dim propertyExist As Boolean: propertyExist = False
            Dim code As String: code = splitStr(1)
            Dim activationCell As Range: Set activationCell = Names("ActivationCell").RefersToRange
            activationCell.Font.Color = RGB(84, 230, 55)
            activationCell.Value = "Активирован"
                
            Dim settingsActivationCell As Range: Set settingsActivationCell = Names("SettingsActivationCell").RefersToRange
            settingsActivationCell.Font.Color = RGB(84, 230, 55)
            settingsActivationCell.Value = "Активирован"
            
            For Each Property In Application.ActiveWorkbook.CustomDocumentProperties
                If Property.name = "asadsjakdjhask" Then
                    Property.Value = code
                    propertyExist = True
                    Exit For
                End If
            Next
            If propertyExist = False Then
                ActiveWorkbook.CustomDocumentProperties.Add _
                    name:="asadsjakdjhask", _
                    LinkToContent:=False, _
                    Type:=msoPropertyTypeString, _
                    Value:=code
            End If
            ActiveWorkbook.Save
            Module3.copyText
            isUpdated = True
        End If
     End If
End Function

Function enableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 0
End Function

Function disableShapeButton(sh As Shape)
    sh.DrawingObject.Font.Color = 8421504
End Function

Function disableDossierActions()
    Dim fillFoldersBtn As Shape, fillTableBtn As Shape, dossierCheckBtn As Shape, xmlExportBtn As Shape, updateBtn As Shape, increaseSeqBtn As Shape, newDossierBtn As Shape
    Dim dossierSheet As Worksheet
    Set dossierSheet = Worksheet____1
    Dim settingsSheet As Worksheet
    Set settingsSheet = Worksheet____4
    Set fillFoldersBtn = dossierSheet.Shapes("Кнопка 6")
    Set fillTableBtn = dossierSheet.Shapes("Кнопка 7")
    Set dossierCheckBtn = dossierSheet.Shapes("Кнопка 3")
    Set xmlExportBtn = dossierSheet.Shapes("Кнопка 4")
    Set increaseSeqBtn = dossierSheet.Shapes("Кнопка 8")
    Set updateBtn = settingsSheet.Shapes("Кнопка 1")
    Set newDossierBtn = settingsSheet.Shapes("Кнопка 2")
    
    Call disableShapeButton(fillFoldersBtn)
    Call disableShapeButton(fillTableBtn)
    Call disableShapeButton(dossierCheckBtn)
    Call disableShapeButton(xmlExportBtn)
    Call disableShapeButton(increaseSeqBtn)
    Call disableShapeButton(updateBtn)
    Call disableShapeButton(newDossierBtn)
    
    BtnsDisabled = True
End Function

Function enableDossierActions()
…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 426496 bytes
SHA-256: b14146547d287b9aada04be2c272b432e7e223db7cdc7fe0406bdaf243a7fb39

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